summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_color.c32
-rw-r--r--generic/regc_cvec.c6
-rw-r--r--generic/regc_lex.c18
-rw-r--r--generic/regc_nfa.c83
-rw-r--r--generic/regcomp.c14
-rw-r--r--generic/regcustom.h14
-rw-r--r--generic/rege_dfa.c212
-rw-r--r--generic/regerror.c2
-rw-r--r--generic/regex.h15
-rw-r--r--generic/regexec.c505
-rw-r--r--generic/regfronts.c6
-rw-r--r--generic/regguts.h19
-rw-r--r--generic/tcl.decls1950
-rw-r--r--generic/tcl.h891
-rw-r--r--generic/tclAlloc.c13
-rw-r--r--generic/tclAssembly.c4310
-rw-r--r--generic/tclAsync.c8
-rw-r--r--generic/tclBasic.c4135
-rw-r--r--generic/tclBinary.c2254
-rw-r--r--generic/tclCkalloc.c103
-rw-r--r--generic/tclClock.c390
-rw-r--r--generic/tclCmdAH.c2316
-rw-r--r--generic/tclCmdIL.c1215
-rw-r--r--generic/tclCmdMZ.c1288
-rw-r--r--generic/tclCompCmds.c3613
-rw-r--r--generic/tclCompCmdsSZ.c3644
-rw-r--r--generic/tclCompExpr.c1007
-rw-r--r--generic/tclCompile.c1145
-rw-r--r--generic/tclCompile.h520
-rw-r--r--generic/tclConfig.c55
-rw-r--r--generic/tclDTrace.d56
-rw-r--r--generic/tclDate.c36
-rw-r--r--generic/tclDecls.h4290
-rw-r--r--generic/tclDictObj.c521
-rw-r--r--generic/tclEncoding.c651
-rw-r--r--generic/tclEnsemble.c2969
-rw-r--r--generic/tclEnv.c51
-rw-r--r--generic/tclEvent.c342
-rw-r--r--generic/tclExecute.c7256
-rw-r--r--generic/tclFCmd.c539
-rw-r--r--generic/tclFileName.c248
-rw-r--r--generic/tclFileSystem.h20
-rw-r--r--generic/tclGet.c55
-rw-r--r--generic/tclGetDate.y36
-rw-r--r--generic/tclHash.c155
-rw-r--r--generic/tclHistory.c90
-rw-r--r--generic/tclIO.c1348
-rw-r--r--generic/tclIO.h15
-rw-r--r--generic/tclIOCmd.c326
-rw-r--r--generic/tclIOGT.c20
-rw-r--r--generic/tclIORChan.c346
-rw-r--r--generic/tclIORTrans.c3400
-rw-r--r--generic/tclIOSock.c171
-rw-r--r--generic/tclIOUtil.c2237
-rw-r--r--generic/tclIndexObj.c917
-rw-r--r--generic/tclInt.decls789
-rw-r--r--generic/tclInt.h1082
-rw-r--r--generic/tclIntDecls.h1399
-rw-r--r--generic/tclIntPlatDecls.h409
-rw-r--r--generic/tclInterp.c528
-rw-r--r--generic/tclLink.c79
-rw-r--r--generic/tclListObj.c196
-rw-r--r--generic/tclLiteral.c218
-rw-r--r--generic/tclLoad.c236
-rw-r--r--generic/tclLoadNone.c57
-rw-r--r--generic/tclMain.c623
-rw-r--r--generic/tclNamesp.c3272
-rw-r--r--generic/tclNotify.c77
-rw-r--r--generic/tclOO.c2723
-rw-r--r--generic/tclOO.decls204
-rw-r--r--generic/tclOO.h126
-rw-r--r--generic/tclOOBasic.c1112
-rw-r--r--generic/tclOOCall.c1264
-rw-r--r--generic/tclOODecls.h247
-rw-r--r--generic/tclOODefineCmds.c2001
-rw-r--r--generic/tclOOInfo.c1464
-rw-r--r--generic/tclOOInt.h626
-rw-r--r--generic/tclOOIntDecls.h184
-rw-r--r--generic/tclOOMethod.c1755
-rw-r--r--generic/tclOOStubInit.c78
-rw-r--r--generic/tclOOStubLib.c84
-rw-r--r--generic/tclObj.c894
-rw-r--r--generic/tclPanic.c58
-rw-r--r--generic/tclParse.c283
-rw-r--r--generic/tclPathObj.c294
-rw-r--r--generic/tclPipe.c186
-rw-r--r--generic/tclPkg.c108
-rw-r--r--generic/tclPkgConfig.c4
-rw-r--r--generic/tclPlatDecls.h71
-rw-r--r--generic/tclPosixStr.c52
-rw-r--r--generic/tclPreserve.c37
-rw-r--r--generic/tclProc.c1046
-rw-r--r--generic/tclRegexp.c51
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResolve.c42
-rw-r--r--generic/tclResult.c242
-rw-r--r--generic/tclScan.c85
-rwxr-xr-xgeneric/tclStrToD.c2318
-rw-r--r--generic/tclStringObj.c1420
-rw-r--r--generic/tclStubInit.c351
-rw-r--r--generic/tclStubLib.c102
-rw-r--r--generic/tclTest.c1209
-rw-r--r--generic/tclTestObj.c314
-rw-r--r--generic/tclTestProcBodyObj.c103
-rw-r--r--generic/tclThread.c67
-rw-r--r--generic/tclThreadAlloc.c99
-rw-r--r--generic/tclThreadJoin.c6
-rw-r--r--generic/tclThreadStorage.c602
-rw-r--r--generic/tclThreadTest.c356
-rw-r--r--generic/tclTimer.c194
-rw-r--r--generic/tclTomMath.decls141
-rw-r--r--generic/tclTomMath.h83
-rw-r--r--generic/tclTomMathDecls.h363
-rw-r--r--generic/tclTomMathInterface.c11
-rw-r--r--generic/tclTomMathStubLib.c89
-rw-r--r--generic/tclTrace.c399
-rw-r--r--generic/tclUtf.c81
-rw-r--r--generic/tclUtil.c400
-rw-r--r--generic/tclVar.c2416
-rw-r--r--generic/tclZlib.c2945
120 files changed, 62468 insertions, 31767 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c
index ba1f668..b7a571c 100644
--- a/generic/regc_color.c
+++ b/generic/regc_color.c
@@ -37,7 +37,7 @@
/*
- initcm - set up new colormap
- ^ static VOID initcm(struct vars *, struct colormap *);
+ ^ static void initcm(struct vars *, struct colormap *);
*/
static void
initcm(
@@ -88,7 +88,7 @@ initcm(
/*
- freecm - free dynamically-allocated things in a colormap
- ^ static VOID freecm(struct colormap *);
+ ^ static void freecm(struct colormap *);
*/
static void
freecm(
@@ -116,7 +116,7 @@ freecm(
/*
- cmtreefree - free a non-terminal part of a colormap tree
- ^ static VOID cmtreefree(struct colormap *, union tree *, int);
+ ^ static void cmtreefree(struct colormap *, union tree *, int);
*/
static void
cmtreefree(
@@ -287,7 +287,7 @@ newcolor(
/*
- freecolor - free a color (must have no arcs or subcolor)
- ^ static VOID freecolor(struct colormap *, pcolor);
+ ^ static void freecolor(struct colormap *, pcolor);
*/
static void
freecolor(
@@ -320,7 +320,7 @@ freecolor(
cm->free = cm->cd[cm->free].sub;
}
if (cm->free > 0) {
- assert(cm->free < cm->max);
+ assert((size_t)cm->free < cm->max);
pco = cm->free;
nco = cm->cd[pco].sub;
while (nco > 0) {
@@ -332,7 +332,7 @@ freecolor(
nco = cm->cd[nco].sub;
cm->cd[pco].sub = nco;
} else {
- assert(nco < cm->max);
+ assert((size_t)nco < cm->max);
pco = nco;
nco = cm->cd[pco].sub;
}
@@ -422,7 +422,7 @@ newsub(
/*
- subrange - allocate new subcolors to this range of chrs, fill in arcs
- ^ static VOID subrange(struct vars *, pchr, pchr, struct state *,
+ ^ static void subrange(struct vars *, pchr, pchr, struct state *,
^ struct state *);
*/
static void
@@ -470,7 +470,7 @@ subrange(
/*
- subblock - allocate new subcolors for one tree block of chrs, fill in arcs
- ^ static VOID subblock(struct vars *, pchr, struct state *, struct state *);
+ ^ static void subblock(struct vars *, pchr, struct state *, struct state *);
*/
static void
subblock(
@@ -575,7 +575,7 @@ subblock(
/*
- okcolors - promote subcolors to full colors
- ^ static VOID okcolors(struct nfa *, struct colormap *);
+ ^ static void okcolors(struct nfa *, struct colormap *);
*/
static void
okcolors(
@@ -636,7 +636,7 @@ okcolors(
/*
- colorchain - add this arc to the color chain of its color
- ^ static VOID colorchain(struct colormap *, struct arc *);
+ ^ static void colorchain(struct colormap *, struct arc *);
*/
static void
colorchain(
@@ -655,7 +655,7 @@ colorchain(
/*
- uncolorchain - delete this arc from the color chain of its color
- ^ static VOID uncolorchain(struct colormap *, struct arc *);
+ ^ static void uncolorchain(struct colormap *, struct arc *);
*/
static void
uncolorchain(
@@ -681,7 +681,7 @@ uncolorchain(
/*
- rainbow - add arcs of all full colors (but one) between specified states
- ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor,
+ ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor,
^ struct state *, struct state *);
*/
static void
@@ -708,7 +708,7 @@ rainbow(
/*
- colorcomplement - add arcs of complementary colors
* The calling sequence ought to be reconciled with cloneouts().
- ^ static VOID colorcomplement(struct nfa *, struct colormap *, int,
+ ^ static void colorcomplement(struct nfa *, struct colormap *, int,
^ struct state *, struct state *, struct state *);
*/
static void
@@ -741,7 +741,7 @@ colorcomplement(
/*
- dumpcolors - debugging output
- ^ static VOID dumpcolors(struct colormap *, FILE *);
+ ^ static void dumpcolors(struct colormap *, FILE *);
*/
static void
dumpcolors(
@@ -789,7 +789,7 @@ dumpcolors(
/*
- fillcheck - check proper filling of a tree
- ^ static VOID fillcheck(struct colormap *, union tree *, int, FILE *);
+ ^ static void fillcheck(struct colormap *, union tree *, int, FILE *);
*/
static void
fillcheck(
@@ -818,7 +818,7 @@ fillcheck(
/*
- dumpchr - print a chr
* Kind of char-centric but works well enough for debug use.
- ^ static VOID dumpchr(pchr, FILE *);
+ ^ static void dumpchr(pchr, FILE *);
*/
static void
dumpchr(
diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c
index 64f34cd..0247521 100644
--- a/generic/regc_cvec.c
+++ b/generic/regc_cvec.c
@@ -74,7 +74,7 @@ clearcvec(
/*
- addchr - add a chr to a cvec
- ^ static VOID addchr(struct cvec *, pchr);
+ ^ static void addchr(struct cvec *, pchr);
*/
static void
addchr(
@@ -86,7 +86,7 @@ addchr(
/*
- addrange - add a range to a cvec
- ^ static VOID addrange(struct cvec *, pchr, pchr);
+ ^ static void addrange(struct cvec *, pchr, pchr);
*/
static void
addrange(
@@ -128,7 +128,7 @@ getcvec(
/*
- freecvec - free a cvec
- ^ static VOID freecvec(struct cvec *);
+ ^ static void freecvec(struct cvec *);
*/
static void
freecvec(
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index bc61e14..f3a46da 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -63,7 +63,7 @@
/*
- lexstart - set up lexical stuff, scan leading options
- ^ static VOID lexstart(struct vars *);
+ ^ static void lexstart(struct vars *);
*/
static void
lexstart(
@@ -89,7 +89,7 @@ lexstart(
/*
- prefixes - implement various special prefixes
- ^ static VOID prefixes(struct vars *);
+ ^ static void prefixes(struct vars *);
*/
static void
prefixes(
@@ -207,7 +207,7 @@ prefixes(
- lexnest - "call a subroutine", interpolating string at the lexical level
* Note, this is not a very general facility. There are a number of
* implicit assumptions about what sorts of strings can be subroutines.
- ^ static VOID lexnest(struct vars *, const chr *, const chr *);
+ ^ static void lexnest(struct vars *, const chr *, const chr *);
*/
static void
lexnest(
@@ -275,7 +275,7 @@ static const chr brbackw[] = { /* \w within brackets */
/*
- lexword - interpolate a bracket expression for word characters
* Possibly ought to inquire whether there is a "word" character class.
- ^ static VOID lexword(struct vars *);
+ ^ static void lexword(struct vars *);
*/
static void
lexword(
@@ -742,10 +742,10 @@ lexescape(
struct vars *v)
{
chr c;
- static chr alert[] = {
+ static const chr alert[] = {
CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t')
};
- static chr esc[] = {
+ static const chr esc[] = {
CHR('E'), CHR('S'), CHR('C')
};
const chr *save;
@@ -922,7 +922,7 @@ lexdigits(
int len;
chr c;
int d;
- CONST uchr ub = (uchr) base;
+ const uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
@@ -1080,7 +1080,7 @@ brenext(
/*
- skip - skip white space and comments in expanded form
- ^ static VOID skip(struct vars *);
+ ^ static void skip(struct vars *);
*/
static void
skip(
@@ -1135,7 +1135,7 @@ newline(void)
static const chr *
ch(void)
{
- static chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') };
+ static const chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') };
return chstr;
}
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 19dbe63..4fb3ea6 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -142,7 +142,7 @@ DecrementSize(
/*
- freenfa - free an entire NFA
- ^ static VOID freenfa(struct nfa *);
+ ^ static void freenfa(struct nfa *);
*/
static void
freenfa(
@@ -242,7 +242,7 @@ newfstate(
/*
- dropstate - delete a state's inarcs and outarcs and free it
- ^ static VOID dropstate(struct nfa *, struct state *);
+ ^ static void dropstate(struct nfa *, struct state *);
*/
static void
dropstate(
@@ -262,7 +262,7 @@ dropstate(
/*
- freestate - free a state, which has no in-arcs or out-arcs
- ^ static VOID freestate(struct nfa *, struct state *);
+ ^ static void freestate(struct nfa *, struct state *);
*/
static void
freestate(
@@ -294,7 +294,7 @@ freestate(
/*
- destroystate - really get rid of an already-freed state
- ^ static VOID destroystate(struct nfa *, struct state *);
+ ^ static void destroystate(struct nfa *, struct state *);
*/
static void
destroystate(
@@ -317,7 +317,7 @@ destroystate(
/*
- newarc - set up a new arc within an NFA
- ^ static VOID newarc(struct nfa *, int, pcolor, struct state *,
+ ^ static void newarc(struct nfa *, int, pcolor, struct state *,
^ struct state *);
*/
static void
@@ -426,7 +426,7 @@ allocarc(
/*
- freearc - free an arc
- ^ static VOID freearc(struct nfa *, struct arc *);
+ ^ static void freearc(struct nfa *, struct arc *);
*/
static void
freearc(
@@ -519,7 +519,7 @@ findarc(
/*
- cparc - allocate a new arc within an NFA, copying details from old one
- ^ static VOID cparc(struct nfa *, struct arc *, struct state *,
+ ^ static void cparc(struct nfa *, struct arc *, struct state *,
^ struct state *);
*/
static void
@@ -538,7 +538,7 @@ cparc(
* existing arcs, and you would be right if it weren't for the desire
* for duplicate suppression, which makes it easier to just make new
* ones to exploit the suppression built into newarc.
- ^ static VOID moveins(struct nfa *, struct state *, struct state *);
+ ^ static void moveins(struct nfa *, struct state *, struct state *);
*/
static void
moveins(
@@ -560,7 +560,7 @@ moveins(
/*
- copyins - copy all in arcs of a state to another state
- ^ static VOID copyins(struct nfa *, struct state *, struct state *);
+ ^ static void copyins(struct nfa *, struct state *, struct state *);
*/
static void
copyins(
@@ -579,7 +579,7 @@ copyins(
/*
- moveouts - move all out arcs of a state to another state
- ^ static VOID moveouts(struct nfa *, struct state *, struct state *);
+ ^ static void moveouts(struct nfa *, struct state *, struct state *);
*/
static void
moveouts(
@@ -599,7 +599,7 @@ moveouts(
/*
- copyouts - copy all out arcs of a state to another state
- ^ static VOID copyouts(struct nfa *, struct state *, struct state *);
+ ^ static void copyouts(struct nfa *, struct state *, struct state *);
*/
static void
copyouts(
@@ -618,7 +618,7 @@ copyouts(
/*
- cloneouts - copy out arcs of a state to another state pair, modifying type
- ^ static VOID cloneouts(struct nfa *, struct state *, struct state *,
+ ^ static void cloneouts(struct nfa *, struct state *, struct state *,
^ struct state *, int);
*/
static void
@@ -642,7 +642,7 @@ cloneouts(
- delsub - delete a sub-NFA, updating subre pointers if necessary
* This uses a recursive traversal of the sub-NFA, marking already-seen
* states using their tmp pointer.
- ^ static VOID delsub(struct nfa *, struct state *, struct state *);
+ ^ static void delsub(struct nfa *, struct state *, struct state *);
*/
static void
delsub(
@@ -665,7 +665,7 @@ delsub(
/*
- deltraverse - the recursive heart of delsub
* This routine's basic job is to destroy all out-arcs of the state.
- ^ static VOID deltraverse(struct nfa *, struct state *, struct state *);
+ ^ static void deltraverse(struct nfa *, struct state *, struct state *);
*/
static void
deltraverse(
@@ -708,7 +708,7 @@ deltraverse(
* Another recursive traversal, this time using tmp to point to duplicates as
* well as mark already-seen states. (You knew there was a reason why it's a
* state pointer, didn't you? :-))
- ^ static VOID dupnfa(struct nfa *, struct state *, struct state *,
+ ^ static void dupnfa(struct nfa *, struct state *, struct state *,
^ struct state *, struct state *);
*/
static void
@@ -725,7 +725,7 @@ dupnfa(
}
stop->tmp = to;
- duptraverse(nfa, start, from);
+ duptraverse(nfa, start, from, 0);
/* done, except for clearing out the tmp pointers */
stop->tmp = NULL;
@@ -734,13 +734,14 @@ dupnfa(
/*
- duptraverse - recursive heart of dupnfa
- ^ static VOID duptraverse(struct nfa *, struct state *, struct state *);
+ ^ static void duptraverse(struct nfa *, struct state *, struct state *);
*/
static void
duptraverse(
struct nfa *nfa,
struct state *s,
- struct state *stmp) /* s's duplicate, or NULL */
+ struct state *stmp, /* s's duplicate, or NULL */
+ int depth)
{
struct arc *a;
@@ -754,8 +755,18 @@ duptraverse(
return;
}
+ /*
+ * 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
+
+ if (depth++ > DUPTRAVERSE_MAX_DEPTH) {
+ NERR(REG_ESPACE);
+ }
+
for (a=s->outs ; a!=NULL && !NISERR() ; a=a->outchain) {
- duptraverse(nfa, a->to, NULL);
+ duptraverse(nfa, a->to, NULL, depth);
if (NISERR()) {
break;
}
@@ -766,7 +777,7 @@ duptraverse(
/*
- cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set
- ^ static VOID cleartraverse(struct nfa *, struct state *);
+ ^ static void cleartraverse(struct nfa *, struct state *);
*/
static void
cleartraverse(
@@ -787,7 +798,7 @@ cleartraverse(
/*
- specialcolors - fill in special colors for an NFA
- ^ static VOID specialcolors(struct nfa *);
+ ^ static void specialcolors(struct nfa *);
*/
static void
specialcolors(
@@ -850,7 +861,7 @@ optimize(
/*
- pullback - pull back constraints backward to (with luck) eliminate them
- ^ static VOID pullback(struct nfa *, FILE *);
+ ^ static void pullback(struct nfa *, FILE *);
*/
static void
pullback(
@@ -1007,7 +1018,7 @@ pull(
/*
- pushfwd - push forward constraints forward to (with luck) eliminate them
- ^ static VOID pushfwd(struct nfa *, FILE *);
+ ^ static void pushfwd(struct nfa *, FILE *);
*/
static void
pushfwd(
@@ -1226,7 +1237,7 @@ combine(
/*
- fixempties - get rid of EMPTY arcs
- ^ static VOID fixempties(struct nfa *, FILE *);
+ ^ static void fixempties(struct nfa *, FILE *);
*/
static void
fixempties(
@@ -1332,7 +1343,7 @@ unempty(
/*
- cleanup - clean up NFA after optimizations
- ^ static VOID cleanup(struct nfa *);
+ ^ static void cleanup(struct nfa *);
*/
static void
cleanup(
@@ -1373,7 +1384,7 @@ cleanup(
/*
- markreachable - recursive marking of reachable states
- ^ static VOID markreachable(struct nfa *, struct state *, struct state *,
+ ^ static void markreachable(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static void
@@ -1397,7 +1408,7 @@ markreachable(
/*
- markcanreach - recursive marking of states which can reach here
- ^ static VOID markcanreach(struct nfa *, struct state *, struct state *,
+ ^ static void markcanreach(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static void
@@ -1445,7 +1456,7 @@ analyze(
/*
- compact - compact an NFA
- ^ static VOID compact(struct nfa *, struct cnfa *);
+ ^ static void compact(struct nfa *, struct cnfa *);
*/
static void
compact(
@@ -1539,7 +1550,7 @@ compact(
- carcsort - sort compacted-NFA arcs by color
* Really dumb algorithm, but if the list is long enough for that to matter,
* you're in real trouble anyway.
- ^ static VOID carcsort(struct carc *, struct carc *);
+ ^ static void carcsort(struct carc *, struct carc *);
*/
static void
carcsort(
@@ -1568,7 +1579,7 @@ carcsort(
/*
- freecnfa - free a compacted NFA
- ^ static VOID freecnfa(struct cnfa *);
+ ^ static void freecnfa(struct cnfa *);
*/
static void
freecnfa(
@@ -1582,7 +1593,7 @@ freecnfa(
/*
- dumpnfa - dump an NFA in human-readable form
- ^ static VOID dumpnfa(struct nfa *, FILE *);
+ ^ static void dumpnfa(struct nfa *, FILE *);
*/
static void
dumpnfa(
@@ -1623,7 +1634,7 @@ dumpnfa(
/*
- dumpstate - dump an NFA state in human-readable form
- ^ static VOID dumpstate(struct state *, FILE *);
+ ^ static void dumpstate(struct state *, FILE *);
*/
static void
dumpstate(
@@ -1653,7 +1664,7 @@ dumpstate(
/*
- dumparcs - dump out-arcs in human-readable form
- ^ static VOID dumparcs(struct state *, FILE *);
+ ^ static void dumparcs(struct state *, FILE *);
*/
static void
dumparcs(
@@ -1696,7 +1707,7 @@ dumprarcs(
/*
- dumparc - dump one outarc in readable form, including prefixing tab
- ^ static VOID dumparc(struct arc *, struct state *, FILE *);
+ ^ static void dumparc(struct arc *, struct state *, FILE *);
*/
static void
dumparc(
@@ -1770,7 +1781,7 @@ dumparc(
/*
- dumpcnfa - dump a compacted NFA in human-readable form
- ^ static VOID dumpcnfa(struct cnfa *, FILE *);
+ ^ static void dumpcnfa(struct cnfa *, FILE *);
*/
static void
dumpcnfa(
@@ -1811,7 +1822,7 @@ dumpcnfa(
/*
- dumpcstate - dump a compacted-NFA state in human-readable form
- ^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *);
+ ^ static void dumpcstate(int, struct carc *, struct cnfa *, FILE *);
*/
static void
dumpcstate(
diff --git a/generic/regcomp.c b/generic/regcomp.c
index 6dea04b..d7ae05e 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -131,7 +131,7 @@ static void cloneouts(struct nfa *, struct state *, struct state *, struct state
static void delsub(struct nfa *, struct state *, struct state *);
static void deltraverse(struct nfa *, struct state *, struct state *);
static void dupnfa(struct nfa *, struct state *, struct state *, struct state *, struct state *);
-static void duptraverse(struct nfa *, struct state *, struct state *);
+static void duptraverse(struct nfa *, struct state *, struct state *, int);
static void cleartraverse(struct nfa *, struct state *);
static void specialcolors(struct nfa *);
static long optimize(struct nfa *, FILE *);
@@ -1458,7 +1458,7 @@ brackpart(
celt startc, endc;
struct cvec *cv;
const chr *startp, *endp;
- chr c[1];
+ chr c;
/*
* Parse something, get rid of special cases, take shortcuts.
@@ -1470,7 +1470,7 @@ brackpart(
return;
break;
case PLAIN:
- c[0] = v->nextvalue;
+ c = v->nextvalue;
NEXT();
/*
@@ -1478,10 +1478,10 @@ brackpart(
*/
if (!SEE(RANGE)) {
- onechr(v, c[0], lp, rp);
+ onechr(v, c, lp, rp);
return;
}
- startc = element(v, c, c+1);
+ startc = element(v, &c, &c+1);
NOERR();
break;
case COLLEL:
@@ -1525,9 +1525,9 @@ brackpart(
switch (v->nexttype) {
case PLAIN:
case RANGE:
- c[0] = v->nextvalue;
+ c = v->nextvalue;
NEXT();
- endc = element(v, c, c+1);
+ endc = element(v, &c, &c+1);
NOERR();
break;
case COLLEL:
diff --git a/generic/regcustom.h b/generic/regcustom.h
index ac33087..bc8c28c 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -30,16 +30,16 @@
* Headers if any.
*/
-#include "tclInt.h"
+#include "regex.h"
/*
* Overrides for regguts.h definitions, if any.
*/
#define FUNCPTR(name, args) (*name)args
-#define MALLOC(n) ckalloc(n)
+#define MALLOC(n) VS(attemptckalloc(n))
#define FREE(p) ckfree(VS(p))
-#define REALLOC(p,n) ckrealloc(VS(p),n)
+#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n))
/*
* Do not insert extras between the "begin" and "end" lines - this chunk is
@@ -155,7 +155,9 @@ typedef int celt; /* Type to hold chr, or NOCELT */
#endif
/*
- * And pick up the standard header.
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
*/
-
-#include "regex.h"
diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c
index e233680..920ea6c 100644
--- a/generic/rege_dfa.c
+++ b/generic/rege_dfa.c
@@ -36,17 +36,16 @@
*/
static chr * /* endpoint, or NULL */
longest(
- struct vars *v, /* used only for debug and exec flags */
- struct dfa *d,
- chr *start, /* where the match should start */
- chr *stop, /* match must end at or before here */
- int *hitstopp) /* record whether hit v->stop, if non-NULL */
+ struct vars *const v, /* used only for debug and exec flags */
+ struct dfa *const d,
+ chr *const start, /* where the match should start */
+ chr *const stop, /* match must end at or before here */
+ int *const hitstopp) /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realstop = (stop == v->stop) ? stop : stop + 1;
color co;
- struct sset *css;
- struct sset *ss;
+ struct sset *css, *ss;
chr *post;
int i;
struct colormap *cm = d->cm;
@@ -164,20 +163,19 @@ longest(
*/
static chr * /* endpoint, or NULL */
shortest(
- struct vars *v,
- struct dfa *d,
- chr *start, /* where the match should start */
- chr *min, /* match must end at or after here */
- chr *max, /* match must end at or before here */
- chr **coldp, /* store coldstart pointer here, if nonNULL */
- int *hitstopp) /* record whether hit v->stop, if non-NULL */
+ struct vars *const v,
+ struct dfa *const d,
+ chr *const start, /* where the match should start */
+ chr *const min, /* match must end at or after here */
+ chr *const max, /* match must end at or before here */
+ chr **const coldp, /* store coldstart pointer here, if nonNULL */
+ int *const hitstopp) /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realmin = (min == v->stop) ? min : min + 1;
chr *realmax = (max == v->stop) ? max : max + 1;
color co;
- struct sset *css;
- struct sset *ss;
+ struct sset *css, *ss;
struct colormap *cm = d->cm;
/*
@@ -256,7 +254,7 @@ shortest(
}
if (coldp != NULL) { /* report last no-progress state set, if any */
- *coldp = lastcold(v, d);
+ *coldp = lastCold(v, d);
}
if ((ss->flags&POSTSTATE) && cp > min) {
@@ -284,19 +282,18 @@ shortest(
}
/*
- - lastcold - determine last point at which no progress had been made
- ^ static chr *lastcold(struct vars *, struct dfa *);
+ - lastCold - determine last point at which no progress had been made
+ ^ static chr *lastCold(struct vars *, struct dfa *);
*/
static chr * /* endpoint, or NULL */
-lastcold(
- struct vars *v,
- struct dfa *d)
+lastCold(
+ struct vars *const v,
+ struct dfa *const d)
{
struct sset *ss;
- chr *nopr;
+ chr *nopr = d->lastnopr;
int i;
- nopr = d->lastnopr;
if (nopr == NULL) {
nopr = v->start;
}
@@ -309,15 +306,15 @@ lastcold(
}
/*
- - newdfa - set up a fresh DFA
- ^ static struct dfa *newdfa(struct vars *, struct cnfa *,
+ - newDFA - set up a fresh DFA
+ ^ static struct dfa *newDFA(struct vars *, struct cnfa *,
^ struct colormap *, struct smalldfa *);
*/
static struct dfa *
-newdfa(
- struct vars *v,
- struct cnfa *cnfa,
- struct colormap *cm,
+newDFA(
+ struct vars *const v,
+ struct cnfa *const cnfa,
+ struct colormap *const cm,
struct smalldfa *sml) /* preallocated space, may be NULL */
{
struct dfa *d;
@@ -345,12 +342,12 @@ newdfa(
d->cptsmalloced = 0;
d->mallocarea = (smallwas == NULL) ? (char *)sml : NULL;
} else {
- d = (struct dfa *)MALLOC(sizeof(struct dfa));
+ d = (struct dfa *) MALLOC(sizeof(struct dfa));
if (d == NULL) {
ERR(REG_ESPACE);
return NULL;
}
- d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset));
+ d->ssets = (struct sset *) MALLOC(nss * sizeof(struct sset));
d->statesarea = (unsigned *)
MALLOC((nss+WORK) * wordsper * sizeof(unsigned));
d->work = &d->statesarea[nss * wordsper];
@@ -362,7 +359,7 @@ newdfa(
d->mallocarea = (char *)d;
if (d->ssets == NULL || d->statesarea == NULL ||
d->outsarea == NULL || d->incarea == NULL) {
- freedfa(d);
+ freeDFA(d);
ERR(REG_ESPACE);
return NULL;
}
@@ -387,12 +384,12 @@ newdfa(
}
/*
- - freedfa - free a DFA
- ^ static void freedfa(struct dfa *);
+ - freeDFA - free a DFA
+ ^ static void freeDFA(struct dfa *);
*/
static void
-freedfa(
- struct dfa *d)
+freeDFA(
+ struct dfa *const d)
{
if (d->cptsmalloced) {
if (d->ssets != NULL) {
@@ -421,8 +418,8 @@ freedfa(
*/
static unsigned
hash(
- unsigned *uv,
- int n)
+ unsigned *const uv,
+ const int n)
{
int i;
unsigned h;
@@ -440,9 +437,9 @@ hash(
*/
static struct sset *
initialize(
- struct vars *v, /* used only for debug flags */
- struct dfa *d,
- chr *start)
+ struct vars *const v, /* used only for debug flags */
+ struct dfa *const d,
+ chr *const start)
{
struct sset *ss;
int i;
@@ -454,7 +451,7 @@ initialize(
if (d->nssused > 0 && (d->ssets[0].flags&STARTER)) {
ss = &d->ssets[0];
} else { /* no, must (re)build it */
- ss = getvacant(v, d, start, start);
+ ss = getVacantSS(v, d, start, start);
for (i = 0; i < d->wordsper; i++) {
ss->states[i] = 0;
}
@@ -484,23 +481,18 @@ initialize(
*/
static struct sset * /* NULL if goes to empty set */
miss(
- struct vars *v, /* used only for debug flags */
- struct dfa *d,
- struct sset *css,
- pcolor co,
- chr *cp, /* next chr */
- chr *start) /* where the attempt got started */
+ struct vars *const v, /* used only for debug flags */
+ struct dfa *const d,
+ struct sset *const css,
+ const pcolor co,
+ chr *const cp, /* next chr */
+ chr *const start) /* where the attempt got started */
{
struct cnfa *cnfa = d->cnfa;
- int i;
unsigned h;
struct carc *ca;
struct sset *p;
- int ispost;
- int noprogress;
- int gotstate;
- int dolacons;
- int sawlacons;
+ int i, isPost, noProgress, gotState, doLAConstraints, sawLAConstraints;
/*
* For convenience, we can be called even if it might not be a miss.
@@ -519,57 +511,57 @@ miss(
for (i = 0; i < d->wordsper; i++) {
d->work[i] = 0;
}
- ispost = 0;
- noprogress = 1;
- gotstate = 0;
+ isPost = 0;
+ noProgress = 1;
+ gotState = 0;
for (i = 0; i < d->nstates; i++) {
if (ISBSET(css->states, i)) {
for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) {
if (ca->co == co) {
BSET(d->work, ca->to);
- gotstate = 1;
+ gotState = 1;
if (ca->to == cnfa->post) {
- ispost = 1;
+ isPost = 1;
}
if (!cnfa->states[ca->to]->co) {
- noprogress = 0;
+ noProgress = 0;
}
FDEBUG(("%d -> %d\n", i, ca->to));
}
}
}
}
- dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0;
- sawlacons = 0;
- while (dolacons) { /* transitive closure */
- dolacons = 0;
+ doLAConstraints = (gotState ? (cnfa->flags&HASLACONS) : 0);
+ sawLAConstraints = 0;
+ while (doLAConstraints) { /* transitive closure */
+ doLAConstraints = 0;
for (i = 0; i < d->nstates; i++) {
if (ISBSET(d->work, i)) {
for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) {
if (ca->co <= cnfa->ncolors) {
- continue; /* NOTE CONTINUE */
+ continue; /* NOTE CONTINUE */
}
- sawlacons = 1;
+ sawLAConstraints = 1;
if (ISBSET(d->work, ca->to)) {
- continue; /* NOTE CONTINUE */
+ continue; /* NOTE CONTINUE */
}
- if (!lacon(v, cnfa, cp, ca->co)) {
- continue; /* NOTE CONTINUE */
+ if (!checkLAConstraint(v, cnfa, cp, ca->co)) {
+ continue; /* NOTE CONTINUE */
}
BSET(d->work, ca->to);
- dolacons = 1;
+ doLAConstraints = 1;
if (ca->to == cnfa->post) {
- ispost = 1;
+ isPost = 1;
}
if (!cnfa->states[ca->to]->co) {
- noprogress = 0;
+ noProgress = 0;
}
FDEBUG(("%d :> %d\n", i, ca->to));
}
}
}
}
- if (!gotstate) {
+ if (!gotState) {
return NULL;
}
h = HASH(d->work, d->wordsper);
@@ -585,14 +577,14 @@ miss(
}
}
if (i == 0) { /* nope, need a new cache entry */
- p = getvacant(v, d, cp, start);
+ p = getVacantSS(v, d, cp, start);
assert(p != css);
for (i = 0; i < d->wordsper; i++) {
p->states[i] = d->work[i];
}
p->hash = h;
- p->flags = (ispost) ? POSTSTATE : 0;
- if (noprogress) {
+ p->flags = (isPost ? POSTSTATE : 0);
+ if (noProgress) {
p->flags |= NOPROGRESS;
}
@@ -601,26 +593,26 @@ miss(
*/
}
- if (!sawlacons) { /* lookahead conds. always cache miss */
+ if (!sawLAConstraints) { /* lookahead conds. always cache miss */
FDEBUG(("c%d[%d]->c%d\n", css - d->ssets, co, p - d->ssets));
css->outs[co] = p;
css->inchain[co] = p->ins;
p->ins.ss = css;
- p->ins.co = (color)co;
+ p->ins.co = (color) co;
}
return p;
}
/*
- - lacon - lookahead-constraint checker for miss()
- ^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor);
+ - checkLAConstraint - lookahead-constraint checker for miss()
+ ^ static int checkLAConstraint(struct vars *, struct cnfa *, chr *, pcolor);
*/
static int /* predicate: constraint satisfied? */
-lacon(
- struct vars *v,
- struct cnfa *pcnfa, /* parent cnfa */
- chr *cp,
- pcolor co) /* "color" of the lookahead constraint */
+checkLAConstraint(
+ struct vars *const v,
+ struct cnfa *const pcnfa, /* parent cnfa */
+ chr *const cp,
+ const pcolor co) /* "color" of the lookahead constraint */
{
int n;
struct subre *sub;
@@ -632,38 +624,36 @@ lacon(
assert(n < v->g->nlacons && v->g->lacons != NULL);
FDEBUG(("=== testing lacon %d\n", n));
sub = &v->g->lacons[n];
- d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd);
+ d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd);
if (d == NULL) {
ERR(REG_ESPACE);
return 0;
}
- end = longest(v, d, cp, v->stop, (int *)NULL);
- freedfa(d);
+ end = longest(v, d, cp, v->stop, NULL);
+ freeDFA(d);
FDEBUG(("=== lacon %d match %d\n", n, (end != NULL)));
return (sub->subno) ? (end != NULL) : (end == NULL);
}
/*
- - getvacant - get a vacant state set
+ - getVacantSS - get a vacant state set
* This routine clears out the inarcs and outarcs, but does not otherwise
* clear the innards of the state set -- that's up to the caller.
- ^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *);
+ ^ static struct sset *getVacantSS(struct vars *, struct dfa *, chr *, chr *);
*/
static struct sset *
-getvacant(
- struct vars *v, /* used only for debug flags */
- struct dfa *d,
- chr *cp,
- chr *start)
+getVacantSS(
+ struct vars *const v, /* used only for debug flags */
+ struct dfa *const d,
+ chr *const cp,
+ chr *const start)
{
int i;
- struct sset *ss;
- struct sset *p;
- struct arcp ap;
- struct arcp lastap = {NULL, 0}; /* silence gcc 4 warning */
+ struct sset *ss, *p;
+ struct arcp ap, lastap = {NULL, 0}; /* silence gcc 4 warning */
color co;
- ss = pickss(v, d, cp, start);
+ ss = pickNextSS(v, d, cp, start);
assert(!(ss->flags&LOCKED));
/*
@@ -695,8 +685,7 @@ getvacant(
p->ins = ss->inchain[i];
} else {
assert(p->ins.ss != NULL);
- for (ap = p->ins; ap.ss != NULL &&
- !(ap.ss == ss && ap.co == i);
+ for (ap = p->ins; ap.ss != NULL && !(ap.ss == ss && ap.co == i);
ap = ap.ss->inchain[ap.co]) {
lastap = ap;
}
@@ -729,19 +718,18 @@ getvacant(
}
/*
- - pickss - pick the next stateset to be used
- ^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *);
+ - pickNextSS - pick the next stateset to be used
+ ^ static struct sset *pickNextSS(struct vars *, struct dfa *, chr *, chr *);
*/
static struct sset *
-pickss(
- struct vars *v, /* used only for debug flags */
- struct dfa *d,
- chr *cp,
- chr *start)
+pickNextSS(
+ struct vars *const v, /* used only for debug flags */
+ struct dfa *const d,
+ chr *const cp,
+ chr *const start)
{
int i;
- struct sset *ss;
- struct sset *end;
+ struct sset *ss, *end;
chr *ancient;
/*
diff --git a/generic/regerror.c b/generic/regerror.c
index 49b6f3e..a1a0163 100644
--- a/generic/regerror.c
+++ b/generic/regerror.c
@@ -35,7 +35,7 @@
* Unknown-error explanation.
*/
-static char unk[] = "*** unknown regex error code 0x%x ***";
+static const char unk[] = "*** unknown regex error code 0x%x ***";
/*
* Struct to map among codes, code names, and explanations.
diff --git a/generic/regex.h b/generic/regex.h
index fa86092..d6d46ce 100644
--- a/generic/regex.h
+++ b/generic/regex.h
@@ -1,5 +1,8 @@
#ifndef _REGEX_H_
#define _REGEX_H_ /* never again */
+
+#include "tclInt.h"
+
/*
* regular expressions
*
@@ -104,8 +107,8 @@ extern "C" {
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* not really right, but good enough... */
-#define __REG_VOID_T VOID
-#define __REG_CONST CONST
+#define __REG_VOID_T void
+#define __REG_CONST const
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
@@ -319,3 +322,11 @@ MODULE_SCOPE size_t regerror(int, __REG_CONST regex_t *, char *, size_t);
#endif
#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/regexec.c b/generic/regexec.c
index c902209..9b6a693 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -125,45 +125,46 @@ struct vars {
/* =====^!^===== begin forwards =====^!^===== */
/* automatically gathered by fwd; do not hand-edit */
/* === regexec.c === */
-int exec(regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
-static int find(struct vars *, struct cnfa *, struct colormap *);
-static int cfind(struct vars *, struct cnfa *, struct colormap *);
-static int cfindloop(struct vars *, struct cnfa *, struct colormap *, struct dfa *, struct dfa *, chr **);
-static VOID zapsubs(regmatch_t *, size_t);
-static VOID zapmem(struct vars *, struct subre *);
-static VOID subset(struct vars *, struct subre *, chr *, chr *);
-static int dissect(struct vars *, struct subre *, chr *, chr *);
-static int condissect(struct vars *, struct subre *, chr *, chr *);
-static int altdissect(struct vars *, struct subre *, chr *, chr *);
-static int cdissect(struct vars *, struct subre *, chr *, chr *);
-static int ccondissect(struct vars *, struct subre *, chr *, chr *);
-static int crevdissect(struct vars *, struct subre *, chr *, chr *);
-static int cbrdissect(struct vars *, struct subre *, chr *, chr *);
-static int caltdissect(struct vars *, struct subre *, chr *, chr *);
+int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
+static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const);
+static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const);
+static int complicatedFindLoop(struct vars *const, struct cnfa *const, struct colormap *const, struct dfa *const, struct dfa *const, chr **const);
+static void zapSubexpressions(regmatch_t *const, const size_t);
+static void zapSubtree(struct vars *const, struct subre *const);
+static void subset(struct vars *const, struct subre *const, chr *const, chr *const);
+static int dissect(struct vars *const, struct subre *, chr *const, chr *const);
+static int concatenationDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int alternationDissect(struct vars *const, struct subre *, chr *const, chr *const);
+static inline int complicatedDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int complicatedCapturingDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int complicatedConcatenationDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int complicatedReversedDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int complicatedBackrefDissect(struct vars *const, struct subre *const, chr *const, chr *const);
+static int complicatedAlternationDissect(struct vars *const, struct subre *, chr *const, chr *const);
/* === rege_dfa.c === */
-static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *);
-static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, chr **, int *);
-static chr *lastcold(struct vars *, struct dfa *);
-static struct dfa *newdfa(struct vars *, struct cnfa *, struct colormap *, struct smalldfa *);
-static VOID freedfa(struct dfa *);
-static unsigned hash(unsigned *, int);
-static struct sset *initialize(struct vars *, struct dfa *, chr *);
-static struct sset *miss(struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *);
-static int lacon(struct vars *, struct cnfa *, chr *, pcolor);
-static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *);
-static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *);
+static chr *longest(struct vars *const, struct dfa *const, chr *const, chr *const, int *const);
+static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *const, chr *const, chr **const, int *const);
+static chr *lastCold(struct vars *const, struct dfa *const);
+static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *);
+static void freeDFA(struct dfa *const);
+static unsigned hash(unsigned *const, const int);
+static struct sset *initialize(struct vars *const, struct dfa *const, chr *const);
+static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const);
+static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor);
+static struct sset *getVacantSS(struct vars *const, struct dfa *const, chr *const, chr *const);
+static struct sset *pickNextSS(struct vars *const, struct dfa *const, chr *const, chr *const);
/* automatically gathered by fwd; do not hand-edit */
/* =====^!^===== end forwards =====^!^===== */
/*
- exec - match regular expression
- ^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *,
+ ^ int exec(regex_t *, const chr *, size_t, rm_detail_t *,
^ size_t, regmatch_t [], int);
*/
int
exec(
regex_t *re,
- CONST chr *string,
+ const chr *string,
size_t len,
rm_detail_t *details,
size_t nmatch,
@@ -171,9 +172,8 @@ exec(
int flags)
{
AllocVars(v);
- int st;
+ int st, backref;
size_t n;
- int backref;
#define LOCALMAT 20
regmatch_t mat[LOCALMAT];
#define LOCALMEM 40
@@ -264,9 +264,9 @@ exec(
assert(v->g->tree != NULL);
if (backref) {
- st = cfind(v, &v->g->tree->cnfa, &v->g->cmap);
+ st = complicatedFind(v, &v->g->tree->cnfa, &v->g->cmap);
} else {
- st = find(v, &v->g->tree->cnfa, &v->g->cmap);
+ st = simpleFind(v, &v->g->tree->cnfa, &v->g->cmap);
}
/*
@@ -274,7 +274,7 @@ exec(
*/
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
- zapsubs(pmatch, nmatch);
+ zapSubexpressions(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
}
@@ -294,23 +294,20 @@ exec(
}
/*
- - find - find a match for the main NFA (no-complications case)
- ^ static int find(struct vars *, struct cnfa *, struct colormap *);
+ - simpleFind - find a match for the main NFA (no-complications case)
+ ^ static int simpleFind(struct vars *, struct cnfa *, struct colormap *);
*/
static int
-find(
- struct vars *v,
- struct cnfa *cnfa,
- struct colormap *cm)
+simpleFind(
+ struct vars *const v,
+ struct cnfa *const cnfa,
+ struct colormap *const cm)
{
- struct dfa *s;
- struct dfa *d;
- chr *begin;
- chr *end = NULL;
+ struct dfa *s, *d;
+ chr *begin, *end = NULL;
chr *cold;
- chr *open; /* Open and close of range of possible
+ chr *open, *close; /* Open and close of range of possible
* starts */
- chr *close;
int hitend;
int shorter = (v->g->tree->flags&SHORTER) ? 1 : 0;
@@ -318,13 +315,13 @@ find(
* First, a shot with the search RE.
*/
- s = newdfa(v, &v->g->search, cm, &v->dfa1);
+ s = newDFA(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
MDEBUG(("\nsearch at %ld\n", LOFF(v->start)));
cold = NULL;
close = shortest(v, s, v->start, v->start, v->stop, &cold, NULL);
- freedfa(s);
+ freeDFA(s);
NOERR();
if (v->g->cflags&REG_EXPECT) {
assert(v->details != NULL);
@@ -350,7 +347,7 @@ find(
open = cold;
cold = NULL;
MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
- d = newdfa(v, cnfa, cm, &v->dfa1);
+ d = newDFA(v, cnfa, cm, &v->dfa1);
assert(!(ISERR() && d != NULL));
NOERR();
for (begin = open; begin <= close; begin++) {
@@ -369,7 +366,7 @@ find(
}
}
assert(end != NULL); /* search RE succeeded so loop should */
- freedfa(d);
+ freeDFA(d);
/*
* And pin down details.
@@ -394,38 +391,37 @@ find(
* Submatches.
*/
- zapsubs(v->pmatch, v->nmatch);
+ zapSubexpressions(v->pmatch, v->nmatch);
return dissect(v, v->g->tree, begin, end);
}
/*
- - cfind - find a match for the main NFA (with complications)
- ^ static int cfind(struct vars *, struct cnfa *, struct colormap *);
+ - complicatedFind - find a match for the main NFA (with complications)
+ ^ static int complicatedFind(struct vars *, struct cnfa *, struct colormap *);
*/
static int
-cfind(
- struct vars *v,
- struct cnfa *cnfa,
- struct colormap *cm)
+complicatedFind(
+ struct vars *const v,
+ struct cnfa *const cnfa,
+ struct colormap *const cm)
{
- struct dfa *s;
- struct dfa *d;
+ struct dfa *s, *d;
chr *cold = NULL; /* silence gcc 4 warning */
int ret;
- s = newdfa(v, &v->g->search, cm, &v->dfa1);
+ s = newDFA(v, &v->g->search, cm, &v->dfa1);
NOERR();
- d = newdfa(v, cnfa, cm, &v->dfa2);
+ d = newDFA(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
- freedfa(s);
+ freeDFA(s);
return v->err;
}
- ret = cfindloop(v, cnfa, cm, d, s, &cold);
+ ret = complicatedFindLoop(v, cnfa, cm, d, s, &cold);
- freedfa(d);
- freedfa(s);
+ freeDFA(d);
+ freeDFA(s);
NOERR();
if (v->g->cflags&REG_EXPECT) {
assert(v->details != NULL);
@@ -440,30 +436,26 @@ cfind(
}
/*
- - cfindloop - the heart of cfind
- ^ static int cfindloop(struct vars *, struct cnfa *, struct colormap *,
+ - complicatedFindLoop - the heart of complicatedFind
+ ^ static int complicatedFindLoop(struct vars *, struct cnfa *, struct colormap *,
^ struct dfa *, struct dfa *, chr **);
*/
static int
-cfindloop(
- struct vars *v,
- struct cnfa *cnfa,
- struct colormap *cm,
- struct dfa *d,
- struct dfa *s,
- chr **coldp) /* where to put coldstart pointer */
+complicatedFindLoop(
+ struct vars *const v,
+ struct cnfa *const cnfa,
+ struct colormap *const cm,
+ struct dfa *const d,
+ struct dfa *const s,
+ chr **const coldp) /* where to put coldstart pointer */
{
- chr *begin;
- chr *end;
+ chr *begin, *end;
chr *cold;
- chr *open; /* Open and close of range of possible
+ chr *open, *close; /* Open and close of range of possible
* starts */
- chr *close;
- chr *estart;
- chr *estop;
- int er;
+ chr *estart, *estop;
+ int er, hitend;
int shorter = v->g->tree->flags&SHORTER;
- int hitend;
assert(d != NULL && s != NULL);
cold = NULL;
@@ -479,7 +471,7 @@ cfindloop(
cold = NULL;
MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close)));
for (begin = open; begin <= close; begin++) {
- MDEBUG(("\ncfind trying at %ld\n", LOFF(begin)));
+ MDEBUG(("\ncomplicatedFind trying at %ld\n", LOFF(begin)));
estart = begin;
estop = v->stop;
for (;;) {
@@ -496,9 +488,9 @@ cfindloop(
}
MDEBUG(("tentative end %ld\n", LOFF(end)));
- zapsubs(v->pmatch, v->nmatch);
- zapmem(v, v->g->tree);
- er = cdissect(v, v->g->tree, begin, end);
+ zapSubexpressions(v->pmatch, v->nmatch);
+ zapSubtree(v, v->g->tree);
+ er = complicatedDissect(v, v->g->tree, begin, end);
if (er == REG_OKAY) {
if (v->nmatch > 0) {
v->pmatch[0].rm_so = OFF(begin);
@@ -538,13 +530,13 @@ cfindloop(
}
/*
- - zapsubs - initialize the subexpression matches to "no match"
- ^ static VOID zapsubs(regmatch_t *, size_t);
+ - zapSubexpressions - initialize the subexpression matches to "no match"
+ ^ static void zapSubexpressions(regmatch_t *, size_t);
*/
static void
-zapsubs(
- regmatch_t *p,
- size_t n)
+zapSubexpressions(
+ regmatch_t *const p,
+ const size_t n)
{
size_t i;
@@ -555,13 +547,13 @@ zapsubs(
}
/*
- - zapmem - initialize the retry memory of a subtree to zeros
- ^ static VOID zapmem(struct vars *, struct subre *);
+ - zapSubtree - initialize the retry memory of a subtree to zeros
+ ^ static void zapSubtree(struct vars *, struct subre *);
*/
static void
-zapmem(
- struct vars *v,
- struct subre *t)
+zapSubtree(
+ struct vars *const v,
+ struct subre *const t)
{
if (t == NULL) {
return;
@@ -572,27 +564,27 @@ zapmem(
if (t->op == '(') {
assert(t->subno > 0);
v->pmatch[t->subno].rm_so = -1;
- v->pmatch[t->subno].rm_eo = -1;
+ v->pmatch[t->subno].rm_eo = -1;
}
if (t->left != NULL) {
- zapmem(v, t->left);
+ zapSubtree(v, t->left);
}
if (t->right != NULL) {
- zapmem(v, t->right);
+ zapSubtree(v, t->right);
}
}
/*
- subset - set any subexpression relevant to a successful subre
- ^ static VOID subset(struct vars *, struct subre *, chr *, chr *);
+ ^ static void subset(struct vars *, struct subre *, chr *, chr *);
*/
static void
subset(
- struct vars *v,
- struct subre *sub,
- chr *begin,
- chr *end)
+ struct vars *const v,
+ struct subre *const sub,
+ chr *const begin,
+ chr *const end)
{
int n = sub->subno;
@@ -612,11 +604,14 @@ subset(
*/
static int /* regexec return code */
dissect(
- struct vars *v,
+ struct vars *const v,
struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
+#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION
+ restart:
+#endif
assert(t != NULL);
MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end)));
@@ -626,35 +621,40 @@ dissect(
return REG_OKAY; /* no action, parent did the work */
case '|': /* alternation */
assert(t->left != NULL);
- return altdissect(v, t, begin, end);
+ return alternationDissect(v, t, begin, end);
case 'b': /* back ref -- shouldn't be calling us! */
return REG_ASSERT;
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
- return condissect(v, t, begin, end);
+ return concatenationDissect(v, t, begin, end);
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
assert(t->subno > 0);
subset(v, t, begin, end);
+#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION
+ t = t->left;
+ goto restart;
+#else
return dissect(v, t->left, begin, end);
+#endif
default:
return REG_ASSERT;
}
}
/*
- - condissect - determine concatenation subexpression matches (uncomplicated)
- ^ static int condissect(struct vars *, struct subre *, chr *, chr *);
+ - concatenationDissect - determine concatenation subexpression matches
+ - (uncomplicated)
+ ^ static int concatenationDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-condissect(
- struct vars *v,
- struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+concatenationDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- struct dfa *d;
- struct dfa *d2;
+ struct dfa *d, *d2;
chr *mid;
int i;
int shorter = (t->left->flags&SHORTER) ? 1 : 0;
@@ -664,12 +664,12 @@ condissect(
assert(t->left != NULL && t->left->cnfa.nstates > 0);
assert(t->right != NULL && t->right->cnfa.nstates > 0);
- d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
+ d = newDFA(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
NOERR();
- d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &v->dfa2);
+ d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, &v->dfa2);
if (ISERR()) {
assert(d2 == NULL);
- freedfa(d);
+ freeDFA(d);
return v->err;
}
@@ -683,8 +683,8 @@ condissect(
mid = longest(v, d, begin, end, NULL);
}
if (mid == NULL) {
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_ASSERT;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
@@ -704,8 +704,8 @@ condissect(
*/
MDEBUG(("no midpoint!\n"));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_ASSERT;
}
if (shorter) {
@@ -719,8 +719,8 @@ condissect(
*/
MDEBUG(("failed midpoint!\n"));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_ASSERT;
}
MDEBUG(("new midpoint %ld\n", LOFF(mid)));
@@ -731,8 +731,8 @@ condissect(
*/
MDEBUG(("successful\n"));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
i = dissect(v, t->left, begin, mid);
if (i != REG_OKAY) {
return i;
@@ -741,56 +741,55 @@ condissect(
}
/*
- - altdissect - determine alternative subexpression matches (uncomplicated)
- ^ static int altdissect(struct vars *, struct subre *, chr *, chr *);
+ - alternationDissect - determine alternative subexpression matches (uncomplicated)
+ ^ static int alternationDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-altdissect(
- struct vars *v,
+alternationDissect(
+ struct vars *const v,
struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- struct dfa *d;
int i;
assert(t != NULL);
assert(t->op == '|');
for (i = 0; t != NULL; t = t->right, i++) {
+ struct dfa *d;
+
MDEBUG(("trying %dth\n", i));
assert(t->left != NULL && t->left->cnfa.nstates > 0);
- d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
+ d = newDFA(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
if (ISERR()) {
return v->err;
}
if (longest(v, d, begin, end, NULL) == end) {
MDEBUG(("success\n"));
- freedfa(d);
+ freeDFA(d);
return dissect(v, t->left, begin, end);
}
- freedfa(d);
+ freeDFA(d);
}
return REG_ASSERT; /* none of them matched?!? */
}
/*
- - cdissect - determine subexpression matches (with complications)
+ - complicatedDissect - determine subexpression matches (with complications)
* The retry memory stores the offset of the trial midpoint from begin, plus 1
* so that 0 uniquely means "clean slate".
- ^ static int cdissect(struct vars *, struct subre *, chr *, chr *);
+ ^ static int complicatedDissect(struct vars *, struct subre *, chr *, chr *);
*/
-static int /* regexec return code */
-cdissect(
- struct vars *v,
- struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+static inline int /* regexec return code */
+complicatedDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- int er;
-
assert(t != NULL);
- MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op));
+ MDEBUG(("complicatedDissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op));
switch (t->op) {
case '=': /* terminal node */
@@ -798,61 +797,71 @@ cdissect(
return REG_OKAY; /* no action, parent did the work */
case '|': /* alternation */
assert(t->left != NULL);
- return caltdissect(v, t, begin, end);
+ return complicatedAlternationDissect(v, t, begin, end);
case 'b': /* back ref -- shouldn't be calling us! */
assert(t->left == NULL && t->right == NULL);
- return cbrdissect(v, t, begin, end);
+ return complicatedBackrefDissect(v, t, begin, end);
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
- return ccondissect(v, t, begin, end);
+ return complicatedConcatenationDissect(v, t, begin, end);
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
assert(t->subno > 0);
- er = cdissect(v, t->left, begin, end);
- if (er == REG_OKAY) {
- subset(v, t, begin, end);
- }
- return er;
+ return complicatedCapturingDissect(v, t, begin, end);
default:
return REG_ASSERT;
}
}
+
+static int /* regexec return code */
+complicatedCapturingDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
+{
+ int er = complicatedDissect(v, t->left, begin, end);
+
+ if (er == REG_OKAY) {
+ subset(v, t, begin, end);
+ }
+ return er;
+}
/*
- - ccondissect - concatenation subexpression matches (with complications)
+ - complicatedConcatenationDissect - concatenation subexpression matches (with complications)
* The retry memory stores the offset of the trial midpoint from begin, plus 1
* so that 0 uniquely means "clean slate".
- ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *);
+ ^ static int complicatedConcatenationDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-ccondissect(
- struct vars *v,
- struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+complicatedConcatenationDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
struct dfa *d, *d2;
chr *mid;
- int er;
assert(t->op == '.');
assert(t->left != NULL && t->left->cnfa.nstates > 0);
assert(t->right != NULL && t->right->cnfa.nstates > 0);
if (t->left->flags&SHORTER) { /* reverse scan */
- return crevdissect(v, t, begin, end);
+ return complicatedReversedDissect(v, t, begin, end);
}
- d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
+ d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
return v->err;
}
- d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
+ d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
- freedfa(d);
+ freeDFA(d);
return v->err;
}
- MDEBUG(("cconcat %d\n", t->retry));
+ MDEBUG(("cConcat %d\n", t->retry));
/*
* Pick a tentative midpoint.
@@ -861,8 +870,8 @@ ccondissect(
if (v->mem[t->retry] == 0) {
mid = longest(v, d, begin, end, NULL);
if (mid == NULL) {
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
@@ -882,23 +891,24 @@ ccondissect(
*/
if (longest(v, d2, mid, end, NULL) == end) {
- er = cdissect(v, t->left, begin, mid);
+ int er = complicatedDissect(v, t->left, begin, mid);
+
if (er == REG_OKAY) {
- er = cdissect(v, t->right, mid, end);
+ er = complicatedDissect(v, t->right, mid, end);
if (er == REG_OKAY) {
/*
* Satisfaction.
*/
-
+
MDEBUG(("successful\n"));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_OKAY;
}
}
if ((er != REG_OKAY) && (er != REG_NOMATCH)) {
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return er;
}
}
@@ -913,8 +923,8 @@ ccondissect(
*/
MDEBUG(("%d no midpoint\n", t->retry));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
mid = longest(v, d, begin, mid-1, NULL);
@@ -924,34 +934,33 @@ ccondissect(
*/
MDEBUG(("%d failed midpoint\n", t->retry));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
- zapmem(v, t->left);
- zapmem(v, t->right);
+ zapSubtree(v, t->left);
+ zapSubtree(v, t->right);
}
}
/*
- - crevdissect - determine backref shortest-first subexpression matches
+ - complicatedReversedDissect - determine backref shortest-first subexpression
+ - matches
* The retry memory stores the offset of the trial midpoint from begin, plus 1
* so that 0 uniquely means "clean slate".
- ^ static int crevdissect(struct vars *, struct subre *, chr *, chr *);
+ ^ static int complicatedReversedDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-crevdissect(
- struct vars *v,
- struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+complicatedReversedDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- struct dfa *d;
- struct dfa *d2;
+ struct dfa *d, *d2;
chr *mid;
- int er;
assert(t->op == '.');
assert(t->left != NULL && t->left->cnfa.nstates > 0);
@@ -962,16 +971,16 @@ crevdissect(
* Concatenation -- need to split the substring between parts.
*/
- d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
+ d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
return v->err;
}
- d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
+ d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
- freedfa(d);
+ freeDFA(d);
return v->err;
}
- MDEBUG(("crev %d\n", t->retry));
+ MDEBUG(("cRev %d\n", t->retry));
/*
* Pick a tentative midpoint.
@@ -980,8 +989,8 @@ crevdissect(
if (v->mem[t->retry] == 0) {
mid = shortest(v, d, begin, begin, end, NULL, NULL);
if (mid == NULL) {
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
@@ -1001,23 +1010,24 @@ crevdissect(
*/
if (longest(v, d2, mid, end, NULL) == end) {
- er = cdissect(v, t->left, begin, mid);
+ int er = complicatedDissect(v, t->left, begin, mid);
+
if (er == REG_OKAY) {
- er = cdissect(v, t->right, mid, end);
+ er = complicatedDissect(v, t->right, mid, end);
if (er == REG_OKAY) {
/*
* Satisfaction.
*/
MDEBUG(("successful\n"));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_OKAY;
}
}
if (er != REG_OKAY && er != REG_NOMATCH) {
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return er;
}
}
@@ -1032,8 +1042,8 @@ crevdissect(
*/
MDEBUG(("%d no midpoint\n", t->retry));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
mid = shortest(v, d, begin, mid+1, end, NULL, NULL);
@@ -1043,36 +1053,31 @@ crevdissect(
*/
MDEBUG(("%d failed midpoint\n", t->retry));
- freedfa(d);
- freedfa(d2);
+ freeDFA(d);
+ freeDFA(d2);
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
- zapmem(v, t->left);
- zapmem(v, t->right);
+ zapSubtree(v, t->left);
+ zapSubtree(v, t->right);
}
}
/*
- - cbrdissect - determine backref subexpression matches
- ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *);
+ - complicatedBackrefDissect - determine backref subexpression matches
+ ^ static int complicatedBackrefDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-cbrdissect(
- struct vars *v,
- struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+complicatedBackrefDissect(
+ struct vars *const v,
+ struct subre *const t,
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- int i;
- int n = t->subno;
+ int i, n = t->subno, min = t->min, max = t->max;
+ chr *paren, *p, *stop;
size_t len;
- chr *paren;
- chr *p;
- chr *stop;
- int min = t->min;
- int max = t->max;
assert(t != NULL);
assert(t->op == 'b');
@@ -1123,7 +1128,7 @@ cbrdissect(
i = 0;
for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) {
- if ((*v->g->compare)(paren, p, len) != 0) {
+ if (v->g->compare(paren, p, len) != 0) {
break;
}
i++;
@@ -1144,55 +1149,67 @@ cbrdissect(
}
/*
- - caltdissect - determine alternative subexpression matches (w. complications)
- ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *);
+ - complicatedAlternationDissect - determine alternative subexpression matches (w.
+ - complications)
+ ^ static int complicatedAlternationDissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
-caltdissect(
- struct vars *v,
+complicatedAlternationDissect(
+ struct vars *const v,
struct subre *t,
- chr *begin, /* beginning of relevant substring */
- chr *end) /* end of same */
+ chr *const begin, /* beginning of relevant substring */
+ chr *const end) /* end of same */
{
- struct dfa *d;
int er;
#define UNTRIED 0 /* not yet tried at all */
#define TRYING 1 /* top matched, trying submatches */
#define TRIED 2 /* top didn't match or submatches exhausted */
+#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION
+ if (0) {
+ doRight:
+ t = t->right;
+ }
+#endif
if (t == NULL) {
return REG_NOMATCH;
}
assert(t->op == '|');
if (v->mem[t->retry] == TRIED) {
- return caltdissect(v, t->right, begin, end);
+ goto doRight;
}
- MDEBUG(("calt n%d\n", t->retry));
+ MDEBUG(("cAlt n%d\n", t->retry));
assert(t->left != NULL);
if (v->mem[t->retry] == UNTRIED) {
- d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
+ struct dfa *d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
+
if (ISERR()) {
return v->err;
}
if (longest(v, d, begin, end, NULL) != end) {
- freedfa(d);
+ freeDFA(d);
v->mem[t->retry] = TRIED;
- return caltdissect(v, t->right, begin, end);
+ goto doRight;
}
- freedfa(d);
- MDEBUG(("calt matched\n"));
+ freeDFA(d);
+ MDEBUG(("cAlt matched\n"));
v->mem[t->retry] = TRYING;
}
- er = cdissect(v, t->left, begin, end);
+ er = complicatedDissect(v, t->left, begin, end);
if (er != REG_NOMATCH) {
return er;
}
v->mem[t->retry] = TRIED;
- return caltdissect(v, t->right, begin, end);
+#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION
+ goto doRight;
+#else
+ doRight:
+ return complicatedAlternationDissect(v, t->right, begin, end);
+#endif
}
#include "rege_dfa.c"
diff --git a/generic/regfronts.c b/generic/regfronts.c
index 5003297..088a640 100644
--- a/generic/regfronts.c
+++ b/generic/regfronts.c
@@ -39,7 +39,7 @@
int
regcomp(
regex_t *re,
- CONST char *str,
+ const char *str,
int flags)
{
size_t len;
@@ -61,12 +61,12 @@ regcomp(
int
regexec(
regex_t *re,
- CONST char *str,
+ const char *str,
size_t nmatch,
regmatch_t pmatch[],
int flags)
{
- CONST char *start;
+ const char *start;
size_t len;
int f = flags;
diff --git a/generic/regguts.h b/generic/regguts.h
index 67e3d03..e57b8f8 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -39,15 +39,6 @@
* Things that regcustom.h might override.
*/
-/* standard header files (NULL is a reasonable indicator for them) */
-#ifndef NULL
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-#include <limits.h>
-#include <string.h>
-#endif
-
/* assertions */
#ifndef assert
#ifndef REG_DEBUG
@@ -75,11 +66,6 @@
#define NOPARMS void /* for empty parm lists */
#endif
-/* const */
-#ifndef CONST
-#define CONST const /* for old compilers, might be empty */
-#endif
-
/* function-pointer declarator */
#ifndef FUNCPTR
#if __STDC__ >= 1
@@ -101,9 +87,6 @@
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
-#ifndef CHAR_BIT
-#include <limits.h>
-#endif
#ifndef _POSIX2_RE_DUP_MAX
#define _POSIX2_RE_DUP_MAX 255 /* normally from <limits.h> */
#endif
@@ -400,7 +383,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree;
struct colormap cmap;
- int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t));
+ int FUNCPTR(compare, (const chr *, const chr *, size_t));
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
diff --git a/generic/tcl.decls b/generic/tcl.decls
index b33e808..b758420 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -21,41 +21,42 @@ library tcl
interface tcl
hooks {tclPlat tclInt tclIntPlat}
+scspec EXTERN
# Declare each of the functions in the public Tcl interface. Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.
-declare 0 generic {
- int Tcl_PkgProvideEx(Tcl_Interp *interp, CONST char *name,
- CONST char *version, ClientData clientData)
+declare 0 {
+ int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name,
+ const char *version, const void *clientData)
}
-declare 1 generic {
+declare 1 {
CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
- CONST char *name, CONST char *version, int exact,
- ClientData *clientDataPtr)
+ const char *name, const char *version, int exact,
+ void *clientDataPtr)
}
-declare 2 generic {
- void Tcl_Panic(CONST char *format, ...)
+declare 2 {
+ void Tcl_Panic(const char *format, ...)
}
-declare 3 generic {
+declare 3 {
char *Tcl_Alloc(unsigned int size)
}
-declare 4 generic {
+declare 4 {
void Tcl_Free(char *ptr)
}
-declare 5 generic {
+declare 5 {
char *Tcl_Realloc(char *ptr, unsigned int size)
}
-declare 6 generic {
- char *Tcl_DbCkalloc(unsigned int size, CONST char *file, int line)
+declare 6 {
+ char *Tcl_DbCkalloc(unsigned int size, const char *file, int line)
}
-declare 7 generic {
- int Tcl_DbCkfree(char *ptr, CONST char *file, int line)
+declare 7 {
+ void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
-declare 8 generic {
+declare 8 {
char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
- CONST char *file, int line)
+ const char *file, int line)
}
# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
@@ -69,528 +70,528 @@ declare 9 unix {
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
}
-declare 11 generic {
- void Tcl_SetTimer(Tcl_Time *timePtr)
+declare 11 {
+ void Tcl_SetTimer(const Tcl_Time *timePtr)
}
-declare 12 generic {
+declare 12 {
void Tcl_Sleep(int ms)
}
-declare 13 generic {
- int Tcl_WaitForEvent(Tcl_Time *timePtr)
+declare 13 {
+ int Tcl_WaitForEvent(const Tcl_Time *timePtr)
}
-declare 14 generic {
+declare 14 {
int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 15 generic {
+declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
-declare 16 generic {
- void Tcl_AppendToObj(Tcl_Obj *objPtr, CONST char *bytes, int length)
+declare 16 {
+ void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
-declare 17 generic {
- Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[])
+declare 17 {
+ Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[])
}
-declare 18 generic {
+declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
- Tcl_ObjType *typePtr)
+ const Tcl_ObjType *typePtr)
}
-declare 19 generic {
- void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
+declare 19 {
+ void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 20 generic {
- void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
+declare 20 {
+ void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 21 generic {
- int Tcl_DbIsShared(Tcl_Obj *objPtr, CONST char *file, int line)
+declare 21 {
+ int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 22 generic {
- Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, CONST char *file, int line)
+declare 22 {
+ Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line)
}
-declare 23 generic {
- Tcl_Obj *Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, int length,
- CONST char *file, int line)
+declare 23 {
+ Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length,
+ const char *file, int line)
}
-declare 24 generic {
- Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, CONST char *file,
+declare 24 {
+ Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
-declare 25 generic {
- Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv,
- CONST char *file, int line)
+declare 25 {
+ Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
+ const char *file, int line)
}
-declare 26 generic {
- Tcl_Obj *Tcl_DbNewLongObj(long longValue, CONST char *file, int line)
+declare 26 {
+ Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
-declare 27 generic {
- Tcl_Obj *Tcl_DbNewObj(CONST char *file, int line)
+declare 27 {
+ Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
-declare 28 generic {
- Tcl_Obj *Tcl_DbNewStringObj(CONST char *bytes, int length,
- CONST char *file, int line)
+declare 28 {
+ Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length,
+ const char *file, int line)
}
-declare 29 generic {
+declare 29 {
Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
-declare 30 generic {
+declare 30 {
void TclFreeObj(Tcl_Obj *objPtr)
}
-declare 31 generic {
- int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, int *boolPtr)
+declare 31 {
+ int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr)
}
-declare 32 generic {
+declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr)
}
-declare 33 generic {
+declare 33 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
-declare 34 generic {
- int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src, double *doublePtr)
+declare 34 {
+ int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
-declare 35 generic {
+declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
-declare 36 generic {
+declare 36 {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr)
+ CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
-declare 37 generic {
- int Tcl_GetInt(Tcl_Interp *interp, CONST char *src, int *intPtr)
+declare 37 {
+ int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
-declare 38 generic {
+declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
-declare 39 generic {
+declare 39 {
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
-declare 40 generic {
- Tcl_ObjType *Tcl_GetObjType(CONST char *typeName)
+declare 40 {
+ CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName)
}
-declare 41 generic {
+declare 41 {
char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
-declare 42 generic {
+declare 42 {
void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
-declare 43 generic {
+declare 43 {
int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *elemListPtr)
}
-declare 44 generic {
+declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
-declare 45 generic {
+declare 45 {
int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
-declare 46 generic {
+declare 46 {
int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index,
Tcl_Obj **objPtrPtr)
}
-declare 47 generic {
+declare 47 {
int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr)
}
-declare 48 generic {
+declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
- int count, int objc, Tcl_Obj *CONST objv[])
+ int count, int objc, Tcl_Obj *const objv[])
}
-declare 49 generic {
+declare 49 {
Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
-declare 50 generic {
- Tcl_Obj *Tcl_NewByteArrayObj(CONST unsigned char *bytes, int length)
+declare 50 {
+ Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length)
}
-declare 51 generic {
+declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
-declare 52 generic {
+declare 52 {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
-declare 53 generic {
- Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *CONST objv[])
+declare 53 {
+ Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
}
-declare 54 generic {
+declare 54 {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
-declare 55 generic {
+declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
-declare 56 generic {
- Tcl_Obj *Tcl_NewStringObj(CONST char *bytes, int length)
+declare 56 {
+ Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
}
-declare 57 generic {
+declare 57 {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
-declare 58 generic {
+declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length)
}
-declare 59 generic {
- void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, CONST unsigned char *bytes,
+declare 59 {
+ void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
int length)
}
-declare 60 generic {
+declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
-declare 61 generic {
+declare 61 {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
-declare 62 generic {
- void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[])
+declare 62 {
+ void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
}
-declare 63 generic {
+declare 63 {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
-declare 64 generic {
+declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
}
-declare 65 generic {
- void Tcl_SetStringObj(Tcl_Obj *objPtr, CONST char *bytes, int length)
+declare 65 {
+ void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
-declare 66 generic {
- void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message)
+declare 66 {
+ void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
-declare 67 generic {
- void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message,
+declare 67 {
+ void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
int length)
}
-declare 68 generic {
+declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
-declare 69 generic {
- void Tcl_AppendElement(Tcl_Interp *interp, CONST char *element)
+declare 69 {
+ void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
-declare 70 generic {
+declare 70 {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
-declare 71 generic {
+declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData)
}
-declare 72 generic {
+declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
}
-declare 73 generic {
+declare 73 {
int Tcl_AsyncInvoke(Tcl_Interp *interp, int code)
}
-declare 74 generic {
+declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
-declare 75 generic {
+declare 75 {
int Tcl_AsyncReady(void)
}
-declare 76 generic {
+declare 76 {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
-declare 77 generic {
- char Tcl_Backslash(CONST char *src, int *readPtr)
+declare 77 {
+ char Tcl_Backslash(const char *src, int *readPtr)
}
-declare 78 generic {
- int Tcl_BadChannelOption(Tcl_Interp *interp, CONST char *optionName,
- CONST char *optionList)
+declare 78 {
+ int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
+ const char *optionList)
}
-declare 79 generic {
+declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
ClientData clientData)
}
-declare 80 generic {
+declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
-declare 81 generic {
+declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 82 generic {
- int Tcl_CommandComplete(CONST char *cmd)
+declare 82 {
+ int Tcl_CommandComplete(const char *cmd)
}
-declare 83 generic {
- char *Tcl_Concat(int argc, CONST84 char *CONST *argv)
+declare 83 {
+ char *Tcl_Concat(int argc, CONST84 char *const *argv)
}
-declare 84 generic {
- int Tcl_ConvertElement(CONST char *src, char *dst, int flags)
+declare 84 {
+ int Tcl_ConvertElement(const char *src, char *dst, int flags)
}
-declare 85 generic {
- int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst,
+declare 85 {
+ int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
int flags)
}
-declare 86 generic {
- int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd,
- Tcl_Interp *target, CONST char *targetCmd, int argc,
- CONST84 char *CONST *argv)
+declare 86 {
+ int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
+ Tcl_Interp *target, const char *targetCmd, int argc,
+ CONST84 char *const *argv)
}
-declare 87 generic {
- int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd,
- Tcl_Interp *target, CONST char *targetCmd, int objc,
- Tcl_Obj *CONST objv[])
+declare 87 {
+ int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
+ Tcl_Interp *target, const char *targetCmd, int objc,
+ Tcl_Obj *const objv[])
}
-declare 88 generic {
- Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr,
- CONST char *chanName, ClientData instanceData, int mask)
+declare 88 {
+ Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
+ const char *chanName, ClientData instanceData, int mask)
}
-declare 89 generic {
+declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData)
}
-declare 90 generic {
+declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
-declare 91 generic {
- Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName,
+declare 91 {
+ Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
-declare 92 generic {
+declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
-declare 93 generic {
+declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
-declare 94 generic {
+declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
-declare 95 generic {
- void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name,
+declare 95 {
+ void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
}
-declare 96 generic {
+declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
- CONST char *cmdName,
+ const char *cmdName,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
-declare 97 generic {
- Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, CONST char *slaveName,
+declare 97 {
+ Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName,
int isSafe)
}
-declare 98 generic {
+declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData)
}
-declare 99 generic {
+declare 99 {
Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc, ClientData clientData)
}
-declare 100 generic {
- void Tcl_DeleteAssocData(Tcl_Interp *interp, CONST char *name)
+declare 100 {
+ void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name)
}
-declare 101 generic {
+declare 101 {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData)
}
-declare 102 generic {
+declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
-declare 103 generic {
- int Tcl_DeleteCommand(Tcl_Interp *interp, CONST char *cmdName)
+declare 103 {
+ int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName)
}
-declare 104 generic {
+declare 104 {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
}
-declare 105 generic {
+declare 105 {
void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
}
-declare 106 generic {
+declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
-declare 107 generic {
+declare 107 {
void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
-declare 108 generic {
+declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
}
-declare 109 generic {
+declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
-declare 110 generic {
+declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
-declare 111 generic {
+declare 111 {
void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr)
}
-declare 112 generic {
+declare 112 {
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
-declare 113 generic {
+declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
-declare 114 generic {
+declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
-declare 115 generic {
+declare 115 {
int Tcl_DoOneEvent(int flags)
}
-declare 116 generic {
+declare 116 {
void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
-declare 117 generic {
- char *Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *bytes, int length)
+declare 117 {
+ char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length)
}
-declare 118 generic {
- char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *element)
+declare 118 {
+ char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
}
-declare 119 generic {
+declare 119 {
void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
-declare 120 generic {
+declare 120 {
void Tcl_DStringFree(Tcl_DString *dsPtr)
}
-declare 121 generic {
+declare 121 {
void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
-declare 122 generic {
+declare 122 {
void Tcl_DStringInit(Tcl_DString *dsPtr)
}
-declare 123 generic {
+declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
-declare 124 generic {
+declare 124 {
void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length)
}
-declare 125 generic {
+declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
-declare 126 generic {
+declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
-declare 127 generic {
+declare 127 {
CONST84_RETURN char *Tcl_ErrnoId(void)
}
-declare 128 generic {
+declare 128 {
CONST84_RETURN char *Tcl_ErrnoMsg(int err)
}
-declare 129 generic {
- int Tcl_Eval(Tcl_Interp *interp, CONST char *script)
+declare 129 {
+ int Tcl_Eval(Tcl_Interp *interp, const char *script)
}
# This is obsolete, use Tcl_FSEvalFile
-declare 130 generic {
- int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
+declare 130 {
+ int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
-declare 131 generic {
+declare 131 {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 132 generic {
+declare 132 {
void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
}
-declare 133 generic {
+declare 133 {
void Tcl_Exit(int status)
}
-declare 134 generic {
- int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken,
- CONST char *cmdName)
+declare 134 {
+ int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken,
+ const char *cmdName)
}
-declare 135 generic {
- int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr, int *ptr)
+declare 135 {
+ int Tcl_ExprBoolean(Tcl_Interp *interp, const char *expr, int *ptr)
}
-declare 136 generic {
+declare 136 {
int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
-declare 137 generic {
- int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr, double *ptr)
+declare 137 {
+ int Tcl_ExprDouble(Tcl_Interp *interp, const char *expr, double *ptr)
}
-declare 138 generic {
+declare 138 {
int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
-declare 139 generic {
- int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr, long *ptr)
+declare 139 {
+ int Tcl_ExprLong(Tcl_Interp *interp, const char *expr, long *ptr)
}
-declare 140 generic {
+declare 140 {
int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
}
-declare 141 generic {
+declare 141 {
int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Obj **resultPtrPtr)
}
-declare 142 generic {
- int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr)
+declare 142 {
+ int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
-declare 143 generic {
+declare 143 {
void Tcl_Finalize(void)
}
-declare 144 generic {
- void Tcl_FindExecutable(CONST char *argv0)
+declare 144 {
+ void Tcl_FindExecutable(const char *argv0)
}
-declare 145 generic {
+declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
-declare 146 generic {
+declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
-declare 147 generic {
+declare 147 {
void Tcl_FreeResult(Tcl_Interp *interp)
}
-declare 148 generic {
- int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
+declare 148 {
+ int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *argcPtr, CONST84 char ***argvPtr)
}
-declare 149 generic {
- int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd,
+declare 149 {
+ int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
-declare 150 generic {
- ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name,
+declare 150 {
+ ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
-declare 151 generic {
- Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, CONST char *chanName,
+declare 151 {
+ Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
-declare 152 generic {
+declare 152 {
int Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
-declare 153 generic {
+declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr)
}
-declare 154 generic {
+declare 154 {
ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
-declare 155 generic {
+declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
-declare 156 generic {
+declare 156 {
CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
}
-declare 157 generic {
+declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
- CONST char *optionName, Tcl_DString *dsPtr)
+ const char *optionName, Tcl_DString *dsPtr)
}
-declare 158 generic {
- Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan)
+declare 158 {
+ CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan)
}
-declare 159 generic {
- int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
+declare 159 {
+ int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdInfo *infoPtr)
}
-declare 160 generic {
+declare 160 {
CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
-declare 161 generic {
+declare 161 {
int Tcl_GetErrno(void)
}
-declare 162 generic {
+declare 162 {
CONST84_RETURN char *Tcl_GetHostName(void)
}
-declare 163 generic {
+declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
}
-declare 164 generic {
+declare 164 {
Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
}
-declare 165 generic {
- CONST char *Tcl_GetNameOfExecutable(void)
+declare 165 {
+ const char *Tcl_GetNameOfExecutable(void)
}
-declare 166 generic {
+declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
@@ -598,399 +599,399 @@ declare 166 generic {
# generic interface, so we inlcude it here for compatibility reasons.
declare 167 unix {
- int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *chanID, int forWriting,
+ int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
-declare 168 generic {
- Tcl_PathType Tcl_GetPathType(CONST char *path)
+declare 168 {
+ Tcl_PathType Tcl_GetPathType(const char *path)
}
-declare 169 generic {
+declare 169 {
int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
-declare 170 generic {
+declare 170 {
int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
-declare 171 generic {
+declare 171 {
int Tcl_GetServiceMode(void)
}
-declare 172 generic {
- Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
+declare 172 {
+ Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
-declare 173 generic {
+declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
-declare 174 generic {
+declare 174 {
CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
}
-declare 175 generic {
- CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, CONST char *varName,
+declare 175 {
+ CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
-declare 176 generic {
- CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags)
+declare 176 {
+ CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags)
}
-declare 177 generic {
- int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command)
+declare 177 {
+ int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
-declare 178 generic {
+declare 178 {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 179 generic {
- int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName,
- CONST char *hiddenCmdToken)
+declare 179 {
+ int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
+ const char *hiddenCmdToken)
}
-declare 180 generic {
+declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
-declare 181 generic {
+declare 181 {
void Tcl_InitHashTable(Tcl_HashTable *tablePtr, int keyType)
}
-declare 182 generic {
+declare 182 {
int Tcl_InputBlocked(Tcl_Channel chan)
}
-declare 183 generic {
+declare 183 {
int Tcl_InputBuffered(Tcl_Channel chan)
}
-declare 184 generic {
+declare 184 {
int Tcl_InterpDeleted(Tcl_Interp *interp)
}
-declare 185 generic {
+declare 185 {
int Tcl_IsSafe(Tcl_Interp *interp)
}
# Obsolete, use Tcl_FSJoinPath
-declare 186 generic {
- char *Tcl_JoinPath(int argc, CONST84 char *CONST *argv,
+declare 186 {
+ char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
Tcl_DString *resultPtr)
}
-declare 187 generic {
- int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr,
+declare 187 {
+ int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr,
int type)
}
# This slot is reserved for use by the plus patch:
-# declare 188 generic {
+# declare 188 {
# Tcl_MainLoop
# }
-declare 189 generic {
+declare 189 {
Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode)
}
-declare 190 generic {
+declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
-declare 191 generic {
+declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
-declare 192 generic {
- char *Tcl_Merge(int argc, CONST84 char *CONST *argv)
+declare 192 {
+ char *Tcl_Merge(int argc, CONST84 char *const *argv)
}
-declare 193 generic {
+declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
}
-declare 194 generic {
+declare 194 {
void Tcl_NotifyChannel(Tcl_Channel channel, int mask)
}
-declare 195 generic {
+declare 195 {
Tcl_Obj *Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags)
}
-declare 196 generic {
+declare 196 {
Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
-declare 197 generic {
+declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
CONST84 char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
-declare 198 generic {
- Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, CONST char *fileName,
- CONST char *modeString, int permissions)
+declare 198 {
+ Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName,
+ const char *modeString, int permissions)
}
-declare 199 generic {
+declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
- CONST char *address, CONST char *myaddr, int myport, int async)
+ const char *address, const char *myaddr, int myport, int async)
}
-declare 200 generic {
+declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
- CONST char *host, Tcl_TcpAcceptProc *acceptProc,
+ const char *host, Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData)
}
-declare 201 generic {
+declare 201 {
void Tcl_Preserve(ClientData data)
}
-declare 202 generic {
+declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
-declare 203 generic {
- int Tcl_PutEnv(CONST char *assignment)
+declare 203 {
+ int Tcl_PutEnv(const char *assignment)
}
-declare 204 generic {
+declare 204 {
CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
}
-declare 205 generic {
+declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
-declare 206 generic {
+declare 206 {
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}
-declare 207 generic {
+declare 207 {
void Tcl_ReapDetachedProcs(void)
}
-declare 208 generic {
- int Tcl_RecordAndEval(Tcl_Interp *interp, CONST char *cmd, int flags)
+declare 208 {
+ int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags)
}
-declare 209 generic {
+declare 209 {
int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)
}
-declare 210 generic {
+declare 210 {
void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 211 generic {
- void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
+declare 211 {
+ void Tcl_RegisterObjType(const Tcl_ObjType *typePtr)
}
-declare 212 generic {
- Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern)
+declare 212 {
+ Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, const char *pattern)
}
-declare 213 generic {
+declare 213 {
int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
- CONST char *text, CONST char *start)
+ const char *text, const char *start)
}
-declare 214 generic {
- int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text,
- CONST char *pattern)
+declare 214 {
+ int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
+ const char *pattern)
}
-declare 215 generic {
+declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
CONST84 char **startPtr, CONST84 char **endPtr)
}
-declare 216 generic {
+declare 216 {
void Tcl_Release(ClientData clientData)
}
-declare 217 generic {
+declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
-declare 218 generic {
- int Tcl_ScanElement(CONST char *str, int *flagPtr)
+declare 218 {
+ int Tcl_ScanElement(const char *str, int *flagPtr)
}
-declare 219 generic {
- int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr)
+declare 219 {
+ int Tcl_ScanCountedElement(const char *str, int length, int *flagPtr)
}
# Obsolete
-declare 220 generic {
+declare 220 {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
-declare 221 generic {
+declare 221 {
int Tcl_ServiceAll(void)
}
-declare 222 generic {
+declare 222 {
int Tcl_ServiceEvent(int flags)
}
-declare 223 generic {
- void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name,
+declare 223 {
+ void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
-declare 224 generic {
+declare 224 {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
}
-declare 225 generic {
+declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
- CONST char *optionName, CONST char *newValue)
+ const char *optionName, const char *newValue)
}
-declare 226 generic {
- int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
- CONST Tcl_CmdInfo *infoPtr)
+declare 226 {
+ int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName,
+ const Tcl_CmdInfo *infoPtr)
}
-declare 227 generic {
+declare 227 {
void Tcl_SetErrno(int err)
}
-declare 228 generic {
+declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
-declare 229 generic {
- void Tcl_SetMaxBlockTime(Tcl_Time *timePtr)
+declare 229 {
+ void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
-declare 230 generic {
+declare 230 {
void Tcl_SetPanicProc(Tcl_PanicProc *panicProc)
}
-declare 231 generic {
+declare 231 {
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
-declare 232 generic {
+declare 232 {
void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc)
}
-declare 233 generic {
+declare 233 {
int Tcl_SetServiceMode(int mode)
}
-declare 234 generic {
+declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
-declare 235 generic {
+declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
-declare 236 generic {
+declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
-declare 237 generic {
- CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, CONST char *varName,
- CONST char *newValue, int flags)
+declare 237 {
+ CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+ const char *newValue, int flags)
}
-declare 238 generic {
- CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, CONST char *newValue, int flags)
+declare 238 {
+ CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, const char *newValue, int flags)
}
-declare 239 generic {
+declare 239 {
CONST84_RETURN char *Tcl_SignalId(int sig)
}
-declare 240 generic {
+declare 240 {
CONST84_RETURN char *Tcl_SignalMsg(int sig)
}
-declare 241 generic {
+declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
-declare 242 generic {
- int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr,
+declare 242 {
+ int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
CONST84 char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
-declare 243 generic {
- void Tcl_SplitPath(CONST char *path, int *argcPtr, CONST84 char ***argvPtr)
+declare 243 {
+ void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
}
-declare 244 generic {
- void Tcl_StaticPackage(Tcl_Interp *interp, CONST char *pkgName,
+declare 244 {
+ void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
-declare 245 generic {
- int Tcl_StringMatch(CONST char *str, CONST char *pattern)
+declare 245 {
+ int Tcl_StringMatch(const char *str, const char *pattern)
}
# Obsolete
-declare 246 generic {
+declare 246 {
int Tcl_TellOld(Tcl_Channel chan)
}
-declare 247 generic {
- int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
+declare 247 {
+ int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
-declare 248 generic {
- int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
+declare 248 {
+ int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
-declare 249 generic {
- char *Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name,
+declare 249 {
+ char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
-declare 250 generic {
- int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead)
+declare 250 {
+ int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead)
}
-declare 251 generic {
- void Tcl_UnlinkVar(Tcl_Interp *interp, CONST char *varName)
+declare 251 {
+ void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
-declare 252 generic {
+declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 253 generic {
- int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, int flags)
+declare 253 {
+ int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
-declare 254 generic {
- int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
+declare 254 {
+ int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
-declare 255 generic {
- void Tcl_UntraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
+declare 255 {
+ void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
-declare 256 generic {
- void Tcl_UntraceVar2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags, Tcl_VarTraceProc *proc,
+declare 256 {
+ void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags, Tcl_VarTraceProc *proc,
ClientData clientData)
}
-declare 257 generic {
- void Tcl_UpdateLinkedVar(Tcl_Interp *interp, CONST char *varName)
+declare 257 {
+ void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
-declare 258 generic {
- int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName,
- CONST char *varName, CONST char *localName, int flags)
+declare 258 {
+ int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+ const char *varName, const char *localName, int flags)
}
-declare 259 generic {
- int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, CONST char *part1,
- CONST char *part2, CONST char *localName, int flags)
+declare 259 {
+ int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
+ const char *part2, const char *localName, int flags)
}
-declare 260 generic {
+declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
-declare 261 generic {
- ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, CONST char *varName,
+declare 261 {
+ ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
-declare 262 generic {
- ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags, Tcl_VarTraceProc *procPtr,
+declare 262 {
+ ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData)
}
-declare 263 generic {
- int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen)
+declare 263 {
+ int Tcl_Write(Tcl_Channel chan, const char *s, int slen)
}
-declare 264 generic {
+declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], CONST char *message)
+ Tcl_Obj *const objv[], const char *message)
}
-declare 265 generic {
- int Tcl_DumpActiveMemory(CONST char *fileName)
+declare 265 {
+ int Tcl_DumpActiveMemory(const char *fileName)
}
-declare 266 generic {
- void Tcl_ValidateAllMemory(CONST char *file, int line)
+declare 266 {
+ void Tcl_ValidateAllMemory(const char *file, int line)
}
-declare 267 generic {
+declare 267 {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
-declare 268 generic {
+declare 268 {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
-declare 269 generic {
+declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
-declare 270 generic {
- CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, CONST char *start,
+declare 270 {
+ CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
CONST84 char **termPtr)
}
-declare 271 generic {
- CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
- CONST char *version, int exact)
+declare 271 {
+ CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *version, int exact)
}
-declare 272 generic {
+declare 272 {
CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
- CONST char *name, CONST char *version, int exact,
- ClientData *clientDataPtr)
+ const char *name, const char *version, int exact,
+ void *clientDataPtr)
}
-declare 273 generic {
- int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
- CONST char *version)
+declare 273 {
+ int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+ const char *version)
}
# TIP #268: The internally used new Require function is in slot 573.
-declare 274 generic {
- CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
- CONST char *version, int exact)
+declare 274 {
+ CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *version, int exact)
}
-declare 275 generic {
+declare 275 {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
-declare 276 generic {
+declare 276 {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
-declare 277 generic {
+declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 generic {
- void Tcl_PanicVA(CONST char *format, va_list argList)
+declare 278 {
+ void Tcl_PanicVA(const char *format, va_list argList)
}
-declare 279 generic {
+declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
-declare 280 generic {
+declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
@@ -1008,1107 +1009,1317 @@ declare 280 generic {
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
-declare 281 generic {
+declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
- Tcl_ChannelType *typePtr, ClientData instanceData,
+ const Tcl_ChannelType *typePtr, ClientData instanceData,
int mask, Tcl_Channel prevChan)
}
-declare 282 generic {
+declare 282 {
int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 283 generic {
+declare 283 {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
}
# 284 was reserved, but added in 8.4a2
-declare 284 generic {
+declare 284 {
void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
}
# Reserved for future use (8.0.x vs. 8.1)
-# declare 285 generic {
+# declare 285 {
# }
# Added in 8.1:
-declare 286 generic {
+declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
-declare 287 generic {
- Tcl_Encoding Tcl_CreateEncoding(CONST Tcl_EncodingType *typePtr)
+declare 287 {
+ Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
-declare 288 generic {
+declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
-declare 289 generic {
+declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
-declare 290 generic {
+declare 290 {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
-declare 291 generic {
- int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, int numBytes,
+declare 291 {
+ int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes,
int flags)
}
-declare 292 generic {
- int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
+declare 292 {
+ int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
-declare 293 generic {
+declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
-declare 294 generic {
+declare 294 {
void Tcl_ExitThread(int status)
}
-declare 295 generic {
+declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
-declare 296 generic {
+declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- CONST char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, int srcLen, Tcl_DString *dsPtr)
}
-declare 297 generic {
+declare 297 {
void Tcl_FinalizeThread(void)
}
-declare 298 generic {
+declare 298 {
void Tcl_FinalizeNotifier(ClientData clientData)
}
-declare 299 generic {
+declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
}
-declare 300 generic {
+declare 300 {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
-declare 301 generic {
- Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
+declare 301 {
+ Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
-declare 302 generic {
+declare 302 {
CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
-declare 303 generic {
+declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
-declare 304 generic {
+declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST void *tablePtr, int offset, CONST char *msg, int flags,
+ const void *tablePtr, int offset, const char *msg, int flags,
int *indexPtr)
}
-declare 305 generic {
+declare 305 {
void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
-declare 306 generic {
- Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags)
+declare 306 {
+ Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags)
}
-declare 307 generic {
+declare 307 {
ClientData Tcl_InitNotifier(void)
}
-declare 308 generic {
+declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
-declare 309 generic {
+declare 309 {
void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr)
}
-declare 310 generic {
+declare 310 {
void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
-declare 311 generic {
+declare 311 {
void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
- Tcl_Time *timePtr)
+ const Tcl_Time *timePtr)
}
-declare 312 generic {
- int Tcl_NumUtfChars(CONST char *src, int length)
+declare 312 {
+ int Tcl_NumUtfChars(const char *src, int length)
}
-declare 313 generic {
+declare 313 {
int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
int appendFlag)
}
-declare 314 generic {
+declare 314 {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
-declare 315 generic {
+declare 315 {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
-declare 316 generic {
- int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
+declare 316 {
+ int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
-declare 317 generic {
- Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, Tcl_Obj *newValuePtr, int flags)
+declare 317 {
+ Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
+ const char *part2, Tcl_Obj *newValuePtr, int flags)
}
-declare 318 generic {
+declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
-declare 319 generic {
+declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
Tcl_QueuePosition position)
}
-declare 320 generic {
- Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index)
+declare 320 {
+ Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
}
-declare 321 generic {
+declare 321 {
Tcl_UniChar Tcl_UniCharToLower(int ch)
}
-declare 322 generic {
+declare 322 {
Tcl_UniChar Tcl_UniCharToTitle(int ch)
}
-declare 323 generic {
+declare 323 {
Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
-declare 324 generic {
+declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
-declare 325 generic {
- CONST84_RETURN char *Tcl_UtfAtIndex(CONST char *src, int index)
+declare 325 {
+ CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
}
-declare 326 generic {
- int Tcl_UtfCharComplete(CONST char *src, int length)
+declare 326 {
+ int Tcl_UtfCharComplete(const char *src, int length)
}
-declare 327 generic {
- int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
+declare 327 {
+ int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
-declare 328 generic {
- CONST84_RETURN char *Tcl_UtfFindFirst(CONST char *src, int ch)
+declare 328 {
+ CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
}
-declare 329 generic {
- CONST84_RETURN char *Tcl_UtfFindLast(CONST char *src, int ch)
+declare 329 {
+ CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
}
-declare 330 generic {
- CONST84_RETURN char *Tcl_UtfNext(CONST char *src)
+declare 330 {
+ CONST84_RETURN char *Tcl_UtfNext(const char *src)
}
-declare 331 generic {
- CONST84_RETURN char *Tcl_UtfPrev(CONST char *src, CONST char *start)
+declare 331 {
+ CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
}
-declare 332 generic {
+declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
-declare 333 generic {
+declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- CONST char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, int srcLen, Tcl_DString *dsPtr)
}
-declare 334 generic {
+declare 334 {
int Tcl_UtfToLower(char *src)
}
-declare 335 generic {
+declare 335 {
int Tcl_UtfToTitle(char *src)
}
-declare 336 generic {
- int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr)
+declare 336 {
+ int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr)
}
-declare 337 generic {
+declare 337 {
int Tcl_UtfToUpper(char *src)
}
-declare 338 generic {
- int Tcl_WriteChars(Tcl_Channel chan, CONST char *src, int srcLen)
+declare 338 {
+ int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen)
}
-declare 339 generic {
+declare 339 {
int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
-declare 340 generic {
+declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
-declare 341 generic {
+declare 341 {
CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
}
-declare 342 generic {
- void Tcl_SetDefaultEncodingDir(CONST char *path)
+declare 342 {
+ void Tcl_SetDefaultEncodingDir(const char *path)
}
-declare 343 generic {
+declare 343 {
void Tcl_AlertNotifier(ClientData clientData)
}
-declare 344 generic {
+declare 344 {
void Tcl_ServiceModeHook(int mode)
}
-declare 345 generic {
+declare 345 {
int Tcl_UniCharIsAlnum(int ch)
}
-declare 346 generic {
+declare 346 {
int Tcl_UniCharIsAlpha(int ch)
}
-declare 347 generic {
+declare 347 {
int Tcl_UniCharIsDigit(int ch)
}
-declare 348 generic {
+declare 348 {
int Tcl_UniCharIsLower(int ch)
}
-declare 349 generic {
+declare 349 {
int Tcl_UniCharIsSpace(int ch)
}
-declare 350 generic {
+declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
-declare 351 generic {
+declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
-declare 352 generic {
- int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr)
+declare 352 {
+ int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
-declare 353 generic {
- int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct,
+declare 353 {
+ int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
-declare 354 generic {
- char *Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr,
+declare 354 {
+ char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
int uniLength, Tcl_DString *dsPtr)
}
-declare 355 generic {
- Tcl_UniChar *Tcl_UtfToUniCharDString(CONST char *src,
+declare 355 {
+ Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
int length, Tcl_DString *dsPtr)
}
-declare 356 generic {
+declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
-declare 357 generic {
+declare 357 {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
-declare 358 generic {
+declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
-declare 359 generic {
- void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
- CONST char *command, int length)
+declare 359 {
+ void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
+ const char *command, int length)
}
-declare 360 generic {
- int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *start, int numBytes,
+declare 360 {
+ int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
-declare 361 generic {
- int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *start, int numBytes,
+declare 361 {
+ int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
int nested, Tcl_Parse *parsePtr)
}
-declare 362 generic {
- int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start, int numBytes,
+declare 362 {
+ int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr)
}
-declare 363 generic {
- int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *start,
+declare 363 {
+ int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr)
}
-declare 364 generic {
- int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *start, int numBytes,
+declare 364 {
+ int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
-declare 365 generic {
+declare 365 {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
-declare 366 generic {
- int Tcl_Chdir(CONST char *dirName)
+declare 366 {
+ int Tcl_Chdir(const char *dirName)
}
-declare 367 generic {
- int Tcl_Access(CONST char *path, int mode)
+declare 367 {
+ int Tcl_Access(const char *path, int mode)
}
-declare 368 generic {
- int Tcl_Stat(CONST char *path, struct stat *bufPtr)
+declare 368 {
+ int Tcl_Stat(const char *path, struct stat *bufPtr)
}
-declare 369 generic {
- int Tcl_UtfNcmp(CONST char *s1, CONST char *s2, unsigned long n)
+declare 369 {
+ int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n)
}
-declare 370 generic {
- int Tcl_UtfNcasecmp(CONST char *s1, CONST char *s2, unsigned long n)
+declare 370 {
+ int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n)
}
-declare 371 generic {
- int Tcl_StringCaseMatch(CONST char *str, CONST char *pattern, int nocase)
+declare 371 {
+ int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase)
}
-declare 372 generic {
+declare 372 {
int Tcl_UniCharIsControl(int ch)
}
-declare 373 generic {
+declare 373 {
int Tcl_UniCharIsGraph(int ch)
}
-declare 374 generic {
+declare 374 {
int Tcl_UniCharIsPrint(int ch)
}
-declare 375 generic {
+declare 375 {
int Tcl_UniCharIsPunct(int ch)
}
-declare 376 generic {
+declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
Tcl_Obj *textObj, int offset, int nmatches, int flags)
}
-declare 377 generic {
+declare 377 {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
-declare 378 generic {
- Tcl_Obj *Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars)
+declare 378 {
+ Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars)
}
-declare 379 generic {
- void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
+declare 379 {
+ void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int numChars)
}
-declare 380 generic {
+declare 380 {
int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
-declare 381 generic {
+declare 381 {
Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
-declare 382 generic {
+declare 382 {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
-declare 383 generic {
+declare 383 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
-declare 384 generic {
- void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
+declare 384 {
+ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int length)
}
-declare 385 generic {
+declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
-declare 386 generic {
+declare 386 {
void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
-declare 387 generic {
+declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
}
-declare 388 generic {
+declare 388 {
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
-declare 389 generic {
- int Tcl_GetChannelNamesEx(Tcl_Interp *interp, CONST char *pattern)
+declare 389 {
+ int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
-declare 390 generic {
+declare 390 {
int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
+ int objc, Tcl_Obj *const objv[])
}
-declare 391 generic {
+declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
}
-declare 392 generic {
+declare 392 {
void Tcl_MutexFinalize(Tcl_Mutex *mutex)
}
-declare 393 generic {
- int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc,
+declare 393 {
+ int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc,
ClientData clientData, int stackSize, int flags)
}
# Introduced in 8.3.2
-declare 394 generic {
+declare 394 {
int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
}
-declare 395 generic {
- int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src, int srcLen)
+declare 395 {
+ int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen)
}
-declare 396 generic {
+declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
-declare 397 generic {
+declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
-declare 398 generic {
- CONST84_RETURN char *Tcl_ChannelName(CONST Tcl_ChannelType *chanTypePtr)
+declare 398 {
+ CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
-declare 399 generic {
+declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 400 generic {
+declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 401 generic {
+declare 401 {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 402 generic {
+declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 403 generic {
+declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 404 generic {
+declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 405 generic {
+declare 405 {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 406 generic {
+declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 407 generic {
+declare 407 {
Tcl_DriverGetOptionProc *Tcl_ChannelGetOptionProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 408 generic {
+declare 408 {
Tcl_DriverWatchProc *Tcl_ChannelWatchProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 409 generic {
+declare 409 {
Tcl_DriverGetHandleProc *Tcl_ChannelGetHandleProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 410 generic {
+declare 410 {
Tcl_DriverFlushProc *Tcl_ChannelFlushProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
-declare 411 generic {
+declare 411 {
Tcl_DriverHandlerProc *Tcl_ChannelHandlerProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
# Introduced in 8.4a2
-declare 412 generic {
+declare 412 {
int Tcl_JoinThread(Tcl_ThreadId threadId, int *result)
}
-declare 413 generic {
+declare 413 {
int Tcl_IsChannelShared(Tcl_Channel channel)
}
-declare 414 generic {
+declare 414 {
int Tcl_IsChannelRegistered(Tcl_Interp *interp, Tcl_Channel channel)
}
-declare 415 generic {
+declare 415 {
void Tcl_CutChannel(Tcl_Channel channel)
}
-declare 416 generic {
+declare 416 {
void Tcl_SpliceChannel(Tcl_Channel channel)
}
-declare 417 generic {
+declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
-declare 418 generic {
- int Tcl_IsChannelExisting(CONST char *channelName)
+declare 418 {
+ int Tcl_IsChannelExisting(const char *channelName)
}
-declare 419 generic {
- int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct,
+declare 419 {
+ int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
-declare 420 generic {
- int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr,
- CONST Tcl_UniChar *uniPattern, int nocase)
+declare 420 {
+ int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
+ const Tcl_UniChar *uniPattern, int nocase)
}
-declare 421 generic {
- Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key)
+declare 421 {
+ Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key)
}
-declare 422 generic {
+declare 422 {
Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr)
+ const void *key, int *newPtr)
}
-declare 423 generic {
+declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
- Tcl_HashKeyType *typePtr)
+ const Tcl_HashKeyType *typePtr)
}
-declare 424 generic {
+declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
-declare 425 generic {
- ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, CONST char *varName,
+declare 425 {
+ ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
ClientData prevClientData)
}
-declare 426 generic {
- int Tcl_TraceCommand(Tcl_Interp *interp, CONST char *varName, int flags,
+declare 426 {
+ int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
Tcl_CommandTraceProc *proc, ClientData clientData)
}
-declare 427 generic {
- void Tcl_UntraceCommand(Tcl_Interp *interp, CONST char *varName,
+declare 427 {
+ void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
}
-declare 428 generic {
+declare 428 {
char *Tcl_AttemptAlloc(unsigned int size)
}
-declare 429 generic {
- char *Tcl_AttemptDbCkalloc(unsigned int size, CONST char *file, int line)
+declare 429 {
+ char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line)
}
-declare 430 generic {
+declare 430 {
char *Tcl_AttemptRealloc(char *ptr, unsigned int size)
}
-declare 431 generic {
+declare 431 {
char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
- CONST char *file, int line)
+ const char *file, int line)
}
-declare 432 generic {
+declare 432 {
int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
}
# TIP#10 (thread-aware channels) akupries
-declare 433 generic {
+declare 433 {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
-declare 434 generic {
+declare 434 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
-declare 435 generic {
- int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name,
+declare 435 {
+ int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr, ClientData *clientDataPtr)
}
-declare 436 generic {
- Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern)
+declare 436 {
+ Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
# TIP#36 (better access to 'subst') dkf
-declare 437 generic {
+declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
-declare 438 generic {
+declare 438 {
int Tcl_DetachChannel(Tcl_Interp *interp, Tcl_Channel channel)
}
-declare 439 generic {
+declare 439 {
int Tcl_IsStandardChannel(Tcl_Channel channel)
}
-declare 440 generic {
+declare 440 {
int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
-declare 441 generic {
+declare 441 {
int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)
}
-declare 442 generic {
+declare 442 {
int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr)
}
-declare 443 generic {
+declare 443 {
int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
-declare 444 generic {
- int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *sym1,
- CONST char *sym2, Tcl_PackageInitProc **proc1Ptr,
+declare 444 {
+ int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1,
+ const char *sym2, Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr)
}
-declare 445 generic {
+declare 445 {
int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
- Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
+ Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types)
}
-declare 446 generic {
+declare 446 {
Tcl_Obj *Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
}
-declare 447 generic {
+declare 447 {
int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr)
}
-declare 448 generic {
+declare 448 {
int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
-declare 449 generic {
+declare 449 {
int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
-declare 450 generic {
+declare 450 {
int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval)
}
-declare 451 generic {
+declare 451 {
int Tcl_FSFileAttrsGet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
}
-declare 452 generic {
+declare 452 {
int Tcl_FSFileAttrsSet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)
}
-declare 453 generic {
- CONST char **Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
+declare 453 {
+ const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
}
-declare 454 generic {
+declare 454 {
int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
-declare 455 generic {
+declare 455 {
int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode)
}
-declare 456 generic {
+declare 456 {
Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr,
- CONST char *modeString, int permissions)
+ const char *modeString, int permissions)
}
-declare 457 generic {
+declare 457 {
Tcl_Obj *Tcl_FSGetCwd(Tcl_Interp *interp)
}
-declare 458 generic {
+declare 458 {
int Tcl_FSChdir(Tcl_Obj *pathPtr)
}
-declare 459 generic {
+declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
-declare 460 generic {
+declare 460 {
Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
}
-declare 461 generic {
+declare 461 {
Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr)
}
-declare 462 generic {
+declare 462 {
int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr)
}
-declare 463 generic {
+declare 463 {
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
-declare 464 generic {
+declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
- Tcl_Obj *CONST objv[])
+ Tcl_Obj *const objv[])
}
-declare 465 generic {
+declare 465 {
ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
- Tcl_Filesystem *fsPtr)
+ const Tcl_Filesystem *fsPtr)
}
-declare 466 generic {
+declare 466 {
Tcl_Obj *Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
-declare 467 generic {
+declare 467 {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
-declare 468 generic {
- Tcl_Obj *Tcl_FSNewNativePath(Tcl_Filesystem *fromFilesystem,
+declare 468 {
+ Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
}
-declare 469 generic {
- CONST char *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
+declare 469 {
+ const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
}
-declare 470 generic {
+declare 470 {
Tcl_Obj *Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr)
}
-declare 471 generic {
+declare 471 {
Tcl_Obj *Tcl_FSPathSeparator(Tcl_Obj *pathPtr)
}
-declare 472 generic {
+declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
-declare 473 generic {
- int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr)
+declare 473 {
+ int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr)
}
-declare 474 generic {
- int Tcl_FSUnregister(Tcl_Filesystem *fsPtr)
+declare 474 {
+ int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr)
}
-declare 475 generic {
- ClientData Tcl_FSData(Tcl_Filesystem *fsPtr)
+declare 475 {
+ ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr)
}
-declare 476 generic {
- CONST char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
+declare 476 {
+ const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr)
}
-declare 477 generic {
- Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr)
+declare 477 {
+ CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr)
}
-declare 478 generic {
+declare 478 {
Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr)
}
# TIP#49 (detection of output buffering) akupries
-declare 479 generic {
+declare 479 {
int Tcl_OutputBuffered(Tcl_Channel chan)
}
-declare 480 generic {
- void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr)
+declare 480 {
+ void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr)
}
# TIP#56 (evaluate a parsed script) msofer
-declare 481 generic {
+declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
# TIP#73 (access to current time) kbk
-declare 482 generic {
+declare 482 {
void Tcl_GetTime(Tcl_Time *timeBuf)
}
# TIP#32 (object-enabled traces) kbk
-declare 483 generic {
+declare 483 {
Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
Tcl_CmdObjTraceProc *objProc, ClientData clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
-declare 484 generic {
+declare 484 {
int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr)
}
-declare 485 generic {
+declare 485 {
int Tcl_SetCommandInfoFromToken(Tcl_Command token,
- CONST Tcl_CmdInfo *infoPtr)
+ const Tcl_CmdInfo *infoPtr)
}
### New functions on 64-bit dev branch ###
# TIP#72 (64-bit values) dkf
-declare 486 generic {
+declare 486 {
Tcl_Obj *Tcl_DbNewWideIntObj(Tcl_WideInt wideValue,
- CONST char *file, int line)
+ const char *file, int line)
}
-declare 487 generic {
+declare 487 {
int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_WideInt *widePtr)
}
-declare 488 generic {
+declare 488 {
Tcl_Obj *Tcl_NewWideIntObj(Tcl_WideInt wideValue)
}
-declare 489 generic {
+declare 489 {
void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue)
}
-declare 490 generic {
+declare 490 {
Tcl_StatBuf *Tcl_AllocStatBuf(void)
}
-declare 491 generic {
+declare 491 {
Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
}
-declare 492 generic {
+declare 492 {
Tcl_WideInt Tcl_Tell(Tcl_Channel chan)
}
# TIP#91 (back-compat enhancements for channels) dkf
-declare 493 generic {
+declare 493 {
Tcl_DriverWideSeekProc *Tcl_ChannelWideSeekProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
# ----- BASELINE -- FOR -- 8.4.0 ----- #
# TIP#111 (dictionaries) dkf
-declare 494 generic {
+declare 494 {
int Tcl_DictObjPut(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr, Tcl_Obj *valuePtr)
}
-declare 495 generic {
+declare 495 {
int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr,
Tcl_Obj **valuePtrPtr)
}
-declare 496 generic {
+declare 496 {
int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr)
}
-declare 497 generic {
+declare 497 {
int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr)
}
-declare 498 generic {
+declare 498 {
int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr)
}
-declare 499 generic {
+declare 499 {
void Tcl_DictObjNext(Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr)
}
-declare 500 generic {
+declare 500 {
void Tcl_DictObjDone(Tcl_DictSearch *searchPtr)
}
-declare 501 generic {
+declare 501 {
int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *CONST *keyv, Tcl_Obj *valuePtr)
+ int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
}
-declare 502 generic {
+declare 502 {
int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *CONST *keyv)
+ int keyc, Tcl_Obj *const *keyv)
}
-declare 503 generic {
+declare 503 {
Tcl_Obj *Tcl_NewDictObj(void)
}
-declare 504 generic {
- Tcl_Obj *Tcl_DbNewDictObj(CONST char *file, int line)
+declare 504 {
+ Tcl_Obj *Tcl_DbNewDictObj(const char *file, int line)
}
# TIP#59 (configuration reporting) akupries
-declare 505 generic {
- void Tcl_RegisterConfig(Tcl_Interp *interp, CONST char *pkgName,
- Tcl_Config *configuration, CONST char *valEncoding)
+declare 505 {
+ void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName,
+ const Tcl_Config *configuration, const char *valEncoding)
}
# TIP #139 (partial exposure of namespace API - transferred from tclInt.decls)
# dkf, API by Brent Welch?
-declare 506 generic {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name,
+declare 506 {
+ Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
-declare 507 generic {
+declare 507 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
-declare 508 generic {
+declare 508 {
int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
-declare 509 generic {
+declare 509 {
int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int resetListFirst)
+ const char *pattern, int resetListFirst)
}
-declare 510 generic {
+declare 510 {
int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int allowOverwrite)
+ const char *pattern, int allowOverwrite)
}
-declare 511 generic {
+declare 511 {
int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern)
+ const char *pattern)
}
-declare 512 generic {
+declare 512 {
Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
}
-declare 513 generic {
+declare 513 {
Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
}
-declare 514 generic {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name,
+declare 514 {
+ Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 515 generic {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name,
+declare 515 {
+ Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 516 generic {
+declare 516 {
Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 517 generic {
+declare 517 {
void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
-declare 518 generic {
+declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
- CONST char *encodingName)
+ const char *encodingName)
}
# TIP#121 (exit handler) dkf for Joe Mistachkin
-declare 519 generic {
+declare 519 {
Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc)
}
# TIP#143 (resource limits) dkf
-declare 520 generic {
+declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, ClientData clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
-declare 521 generic {
+declare 521 {
void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, ClientData clientData)
}
-declare 522 generic {
+declare 522 {
int Tcl_LimitReady(Tcl_Interp *interp)
}
-declare 523 generic {
+declare 523 {
int Tcl_LimitCheck(Tcl_Interp *interp)
}
-declare 524 generic {
+declare 524 {
int Tcl_LimitExceeded(Tcl_Interp *interp)
}
-declare 525 generic {
+declare 525 {
void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit)
}
-declare 526 generic {
+declare 526 {
void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr)
}
-declare 527 generic {
+declare 527 {
void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type, int granularity)
}
-declare 528 generic {
+declare 528 {
int Tcl_LimitTypeEnabled(Tcl_Interp *interp, int type)
}
-declare 529 generic {
+declare 529 {
int Tcl_LimitTypeExceeded(Tcl_Interp *interp, int type)
}
-declare 530 generic {
+declare 530 {
void Tcl_LimitTypeSet(Tcl_Interp *interp, int type)
}
-declare 531 generic {
+declare 531 {
void Tcl_LimitTypeReset(Tcl_Interp *interp, int type)
}
-declare 532 generic {
+declare 532 {
int Tcl_LimitGetCommands(Tcl_Interp *interp)
}
-declare 533 generic {
+declare 533 {
void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr)
}
-declare 534 generic {
+declare 534 {
int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type)
}
# TIP#226 (interpreter result state management) dgp
-declare 535 generic {
+declare 535 {
Tcl_InterpState Tcl_SaveInterpState(Tcl_Interp *interp, int status)
}
-declare 536 generic {
+declare 536 {
int Tcl_RestoreInterpState(Tcl_Interp *interp, Tcl_InterpState state)
}
-declare 537 generic {
+declare 537 {
void Tcl_DiscardInterpState(Tcl_InterpState state)
}
# TIP#227 (return options interface) dgp
-declare 538 generic {
+declare 538 {
int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options)
}
-declare 539 generic {
+declare 539 {
Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result)
}
# TIP#235 (ensembles) dkf
-declare 540 generic {
+declare 540 {
int Tcl_IsEnsemble(Tcl_Command token)
}
-declare 541 generic {
- Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, CONST char *name,
+declare 541 {
+ Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, const char *name,
Tcl_Namespace *namespacePtr, int flags)
}
-declare 542 generic {
+declare 542 {
Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp, Tcl_Obj *cmdNameObj,
int flags)
}
-declare 543 generic {
+declare 543 {
int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj *subcmdList)
}
-declare 544 generic {
+declare 544 {
int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj *mapDict)
}
-declare 545 generic {
+declare 545 {
int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj *unknownList)
}
-declare 546 generic {
+declare 546 {
int Tcl_SetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int flags)
}
-declare 547 generic {
+declare 547 {
int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj **subcmdListPtr)
}
-declare 548 generic {
+declare 548 {
int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj **mapDictPtr)
}
-declare 549 generic {
+declare 549 {
int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj **unknownListPtr)
}
-declare 550 generic {
+declare 550 {
int Tcl_GetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token,
int *flagsPtr)
}
-declare 551 generic {
+declare 551 {
int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token,
Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (virtualized time) akupries
-declare 552 generic {
+declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
ClientData clientData)
}
-declare 553 generic {
+declare 553 {
void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
ClientData *clientData)
}
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
-declare 554 generic {
+declare 554 {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
# TIP#237 (arbitrary-precision integers) kbk
-declare 555 generic {
+declare 555 {
Tcl_Obj *Tcl_NewBignumObj(mp_int *value)
}
-declare 556 generic {
- Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, CONST char *file, int line)
+declare 556 {
+ Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, const char *file, int line)
}
-declare 557 generic {
+declare 557 {
void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value)
}
-declare 558 generic {
+declare 558 {
int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
}
-declare 559 generic {
+declare 559 {
int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
}
# TIP #208 ('chan' command) jeffh
-declare 560 generic {
+declare 560 {
int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
-declare 561 generic {
+declare 561 {
Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
- CONST Tcl_ChannelType *chanTypePtr)
+ const Tcl_ChannelType *chanTypePtr)
}
# TIP#219 (channel reflection api) akupries
-declare 562 generic {
+declare 562 {
void Tcl_SetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj *msg)
}
-declare 563 generic {
+declare 563 {
void Tcl_GetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj **msg)
}
-declare 564 generic {
+declare 564 {
void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg)
}
-declare 565 generic {
+declare 565 {
void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg)
}
# TIP #237 (additional conversion functions for bignum support) kbk/dgp
-declare 566 generic {
+declare 566 {
int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval,
mp_int *toInit)
}
# TIP#181 (namespace unknown command) dgp for Neil Madden
-declare 567 generic {
+declare 567 {
Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr)
}
-declare 568 generic {
+declare 568 {
int Tcl_SetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr)
}
# TIP#258 (enhanced interface for encodings) dgp
-declare 569 generic {
+declare 569 {
int Tcl_GetEncodingFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
}
-declare 570 generic {
+declare 570 {
Tcl_Obj *Tcl_GetEncodingSearchPath(void)
}
-declare 571 generic {
+declare 571 {
int Tcl_SetEncodingSearchPath(Tcl_Obj *searchPath)
}
-declare 572 generic {
- CONST char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
+declare 572 {
+ const char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
}
# TIP#268 (extended version numbers and requirements) akupries
-declare 573 generic {
- int Tcl_PkgRequireProc(Tcl_Interp *interp, CONST char *name,
- int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr)
+declare 573 {
+ int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
+ int objc, Tcl_Obj *const objv[], void *clientDataPtr)
}
# TIP#270 (utility C routines for string formatting) dgp
-declare 574 generic {
+declare 574 {
void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 575 generic {
- void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, CONST char *bytes, int length,
- int limit, CONST char *ellipsis)
+declare 575 {
+ void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length,
+ int limit, const char *ellipsis)
}
-declare 576 generic {
- Tcl_Obj *Tcl_Format(Tcl_Interp *interp, CONST char *format, int objc,
- Tcl_Obj *CONST objv[])
+declare 576 {
+ Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc,
+ Tcl_Obj *const objv[])
}
-declare 577 generic {
+declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST char *format, int objc, Tcl_Obj *CONST objv[])
+ const char *format, int objc, Tcl_Obj *const objv[])
}
-declare 578 generic {
- Tcl_Obj *Tcl_ObjPrintf(CONST char *format, ...)
+declare 578 {
+ Tcl_Obj *Tcl_ObjPrintf(const char *format, ...)
}
-declare 579 generic {
- void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, CONST char *format, ...)
+declare 579 {
+ void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...)
}
+# ----- BASELINE -- FOR -- 8.5.0 ----- #
+
+# TIP #285 (script cancellation support) jmistachkin
+declare 580 {
+ int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
+ ClientData clientData, int flags)
+}
+declare 581 {
+ int Tcl_Canceled(Tcl_Interp *interp, int flags)
+}
+
+# TIP#304 (chan pipe) aferrieux
+declare 582 {
+ int Tcl_CreatePipe(Tcl_Interp *interp, Tcl_Channel *rchan,
+ Tcl_Channel *wchan, int flags)
+}
+
+# TIP #322 (NRE public interface) msofer
+declare 583 {
+ Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc, ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 584 {
+ int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
+declare 585 {
+ int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
+ int flags)
+}
+declare 586 {
+ int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc,
+ Tcl_Obj *const objv[], int flags)
+}
+declare 587 {
+ void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr,
+ ClientData data0, ClientData data1, ClientData data2,
+ ClientData data3)
+}
+# For use by NR extenders, to have a simple way to also provide a (required!)
+# classic objProc
+declare 588 {
+ int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
+ ClientData clientData, int objc, Tcl_Obj *const objv[])
+}
+
+# TIP#316 (Tcl_StatBuf reader functions) dkf
+declare 589 {
+ unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 590 {
+ unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 591 {
+ unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 592 {
+ int Tcl_GetLinkCountFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 593 {
+ int Tcl_GetUserIdFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 594 {
+ int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 595 {
+ int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 596 {
+ Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 597 {
+ Tcl_WideInt Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 598 {
+ Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 599 {
+ Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 600 {
+ Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr)
+}
+declare 601 {
+ unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr)
+}
+
+# TIP#314 (ensembles with parameters) dkf for Lars Hellstr"om
+declare 602 {
+ int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token,
+ Tcl_Obj *paramList)
+}
+declare 603 {
+ int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token,
+ Tcl_Obj **paramListPtr)
+}
+
+# TIP#265 (option parser) dkf for Sam Bromley
+declare 604 {
+ int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
+ int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
+}
+
+# TIP#336 (manipulate the error line) dgp
+declare 605 {
+ int Tcl_GetErrorLine(Tcl_Interp *interp)
+}
+declare 606 {
+ void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum)
+}
+
+# TIP#307 (move results between interpreters) dkf
+declare 607 {
+ void Tcl_TransferResult(Tcl_Interp *sourceInterp, int result,
+ Tcl_Interp *targetInterp)
+}
+
+# TIP#335 (detect if interpreter in use) jmistachkin
+declare 608 {
+ int Tcl_InterpActive(Tcl_Interp *interp)
+}
+
+# TIP#337 (log exception for background processing) dgp
+declare 609 {
+ void Tcl_BackgroundException(Tcl_Interp *interp, int code)
+}
+
+# TIP#234 (zlib interface) dkf/Pascal Scheffers
+declare 610 {
+ int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
+ int level, Tcl_Obj *gzipHeaderDictObj)
+}
+declare 611 {
+ int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
+ int buffersize, Tcl_Obj *gzipHeaderDictObj)
+}
+declare 612 {
+ unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf,
+ int len)
+}
+declare 613 {
+ unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf,
+ int len)
+}
+declare 614 {
+ int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format,
+ int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle)
+}
+declare 615 {
+ Tcl_Obj *Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle)
+}
+declare 616 {
+ int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle)
+}
+declare 617 {
+ int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle)
+}
+declare 618 {
+ int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush)
+}
+declare 619 {
+ int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count)
+}
+declare 620 {
+ int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle)
+}
+declare 621 {
+ int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle)
+}
+
+# TIP 338 (control over startup script) dgp
+declare 622 {
+ void Tcl_SetStartupScript(Tcl_Obj *path, const char *encoding)
+}
+declare 623 {
+ Tcl_Obj *Tcl_GetStartupScript(const char **encodingPtr)
+}
+
+# TIP#332 (half-close made public) aferrieux
+declare 624 {
+ int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan, int flags)
+}
+
+# TIP #353 (NR-enabled expressions) dgp
+declare 625 {
+ int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr)
+}
+
+# TIP #356 (NR-enabled substitution) dgp
+declare 626 {
+ int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
+
+# TIP #357 (Export TclLoadFile and TclpFindSymbol) kbk
+declare 627 {
+ int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ const char *const symv[], int flags, void *procPtrs,
+ Tcl_LoadHandle *handlePtr)
+}
+declare 628 {
+ void* Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle,
+ const char *symbol)
+}
+declare 629 {
+ int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr)
+}
+
+# ----- BASELINE -- FOR -- 8.6.0 ----- #
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
@@ -2126,10 +2337,10 @@ interface tclPlat
# Added in Tcl 8.1
declare 0 win {
- TCHAR *Tcl_WinUtfToTChar(CONST char *str, int len, Tcl_DString *dsPtr)
+ TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr)
}
declare 1 win {
- char *Tcl_WinTCharToUtf(CONST TCHAR *str, int len, Tcl_DString *dsPtr)
+ char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr)
}
################################
@@ -2137,12 +2348,12 @@ declare 1 win {
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- CONST char *bundleName, int hasResourceFile,
+ const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath)
}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
- CONST char *bundleName, CONST char *bundleVersion,
+ const char *bundleName, const char *bundleVersion,
int hasResourceFile, int maxPathLen, char *libraryPath)
}
@@ -2154,38 +2365,13 @@ export {
void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
- CONST char *Tcl_InitStubs(Tcl_Interp *interp, CONST char *version,
- int exact)
-}
-export {
- CONST char *TclTomMathInitializeStubs(Tcl_Interp* interp,
- CONST char* version, int epoch, int revision)
-}
-export {
- CONST char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, CONST char *version,
+ const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
-# Global variables that need to be exported from the tcl shared library.
-
-export {
- TclStubs *tclStubsPtr (fool checkstubs)
-}
-export {
- TclPlatStubs *tclPlatStubsPtr (fool checkstubs)
-}
-export {
- TclIntStubs *tclIntStubsPtr (fool checkstubs)
-}
-export {
- TclIntPlatStubs *tclIntPlatStubsPtr (fool checkstubs)
-}
-export {
- TclTomMathStubs* tclTomMathStubsPtr (fool checkstubs)
-}
# Local Variables:
# mode: tcl
# End:
diff --git a/generic/tcl.h b/generic/tcl.h
index 790b7ac..53dce4b 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -56,14 +56,15 @@ extern "C" {
*/
#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 5
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 9
-
-#define TCL_VERSION "8.5"
-#define TCL_PATCH_LEVEL "8.5.9"
+#define TCL_MINOR_VERSION 6
+#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE
+#define TCL_RELEASE_SERIAL 1
+#define TCL_VERSION "8.6"
+#define TCL_PATCH_LEVEL "8.6b1.2"
+
/*
+ *----------------------------------------------------------------------------
* The following definitions set up the proper options for Windows compilers.
* We use this method because there is no autoconf equivalent.
*/
@@ -139,6 +140,7 @@ extern "C" {
#include <stdio.h>
/*
+ *----------------------------------------------------------------------------
* Support for functions with a variable number of arguments.
*
* The following TCL_VARARGS* macros are to support old extensions
@@ -154,8 +156,14 @@ extern "C" {
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#endif
+#if defined(__GNUC__) && (__GNUC__ > 2)
+# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
+#else
+# define TCL_FORMAT_PRINTF(a,b)
+#endif
/*
+ *----------------------------------------------------------------------------
* Macros used to declare a function to be exported by a DLL. Used by Windows,
* maps to no-op declarations on non-Windows systems. The default build on
* windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
@@ -221,26 +229,34 @@ extern "C" {
#endif
/*
+ * The following _ANSI_ARGS_ macro is to support old extensions
+ * written for older versions of Tcl where it permitted support
+ * for compilers written in the pre-prototype era of C.
+ *
+ * New code should use prototypes.
+ */
+
+#ifndef TCL_NO_DEPRECATED
+# undef _ANSI_ARGS_
+# define _ANSI_ARGS_(x) x
+#endif
+
+/*
* Definitions that allow this header file to be used either with or without
- * ANSI C features like function prototypes.
+ * ANSI C features.
*/
-#undef _ANSI_ARGS_
-#undef CONST
#ifndef INLINE
# define INLINE
#endif
-#ifndef NO_CONST
-# define CONST const
-#else
-# define CONST
+#ifdef NO_CONST
+# ifndef const
+# define const
+# endif
#endif
-
-#ifndef NO_PROTOTYPES
-# define _ANSI_ARGS_(x) x
-#else
-# define _ANSI_ARGS_(x) ()
+#ifndef CONST
+# define CONST const
#endif
#ifdef USE_NON_CONST
@@ -252,13 +268,17 @@ extern "C" {
#else
# ifdef USE_COMPAT_CONST
# define CONST84
-# define CONST84_RETURN CONST
+# define CONST84_RETURN const
# else
-# define CONST84 CONST
-# define CONST84_RETURN CONST
+# define CONST84 const
+# define CONST84_RETURN const
# endif
#endif
+#ifndef CONST86
+# define CONST86 CONST84
+#endif
+
/*
* Make sure EXTERN isn't defined elsewhere.
*/
@@ -274,6 +294,7 @@ extern "C" {
#endif
/*
+ *----------------------------------------------------------------------------
* The following code is copied from winnt.h. If we don't replicate it here,
* then <windows.h> can't be included after tcl.h, since tcl.h also defines
* VOID. This block is skipped under Cygwin and Mingw.
@@ -294,9 +315,9 @@ typedef long LONG;
*/
#ifndef NO_VOID
-#define VOID void
+# define VOID void
#else
-#define VOID char
+# define VOID char
#endif
/*
@@ -427,8 +448,9 @@ typedef struct stat Tcl_StatBuf;
# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */
-
+
/*
+ *----------------------------------------------------------------------------
* Data structures defined opaquely in this module. The definitions below just
* provide dummy types. A few fields are made visible in Tcl_Interp
* structures, namely those used for returning a string result from commands.
@@ -448,9 +470,12 @@ typedef struct stat Tcl_StatBuf;
*/
typedef struct Tcl_Interp {
+ /* TIP #330: Strongly discourage extensions from using the string
+ * result. */
+#ifdef USE_INTERP_RESULT
char *result; /* If the last command returned a string
* result, this points to it. */
- void (*freeProc) _ANSI_ARGS_((char *blockPtr));
+ void (*freeProc) (char *blockPtr);
/* Zero means the string result is statically
* allocated. TCL_DYNAMIC means it was
* allocated with ckalloc and should be freed
@@ -458,9 +483,17 @@ typedef struct Tcl_Interp {
* of function to invoke to free the result.
* Tcl_Eval must free it before executing next
* command. */
+#else
+ char *unused3;
+ void (*unused4) (char *);
+#endif
+#ifdef USE_INTERP_ERRORLINE
int errorLine; /* When TCL_ERROR is returned, this gives the
* line number within the command where the
* error occurred (1 if first line). */
+#else
+ int unused5;
+#endif
} Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
@@ -482,17 +515,19 @@ typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
+typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream;
/*
+ *----------------------------------------------------------------------------
* Definition of the interface to functions implementing threads. A function
* following this definition is given to each call of 'Tcl_CreateThread' and
* will be called as the main fuction of the new thread created by that call.
*/
#if defined __WIN32__
-typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
#else
-typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
#endif
/*
@@ -582,6 +617,7 @@ typedef Tcl_StatBuf *Tcl_Stat_;
typedef struct stat *Tcl_OldStat_;
/*
+ *----------------------------------------------------------------------------
* When a TCL command returns, the interpreter contains a result from the
* command. Programmers are strongly encouraged to use one of the functions
* Tcl_GetObjResult() or Tcl_GetStringResult() to read the interpreter's
@@ -610,6 +646,7 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_RESULT_SIZE 200
/*
+ *----------------------------------------------------------------------------
* Flags to control what substitutions are performed by Tcl_SubstObj():
*/
@@ -642,84 +679,78 @@ typedef struct Tcl_Value {
struct Tcl_Obj;
/*
+ *----------------------------------------------------------------------------
* Function types defined by Tcl:
*/
-typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
-typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int code));
-typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
-typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
-typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
-typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST84 char *argv[]));
-typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, CONST84 char *argv[]));
-typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int level, CONST char *command,
- Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
-typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
- struct Tcl_Obj *dupPtr));
-typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
- CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
- char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr));
-typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
-typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
-typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
- int flags));
-typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
- ClientData clientData));
-typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
- int flags));
-typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
-typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
-typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
-typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp));
-typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
-typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
-typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
-typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
-typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int flags));
-typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...));
-typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
- Tcl_Channel chan, char *address, int port));
-typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
-typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
- struct Tcl_Obj *objPtr));
-typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
-typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2,
- int flags));
-typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
- int flags));
-typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
- Tcl_FileProc *proc, ClientData clientData));
-typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
-typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
-typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
-typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
-
+typedef int (Tcl_AppInitProc) (Tcl_Interp *interp);
+typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp,
+ int code);
+typedef void (Tcl_ChannelProc) (ClientData clientData, int mask);
+typedef void (Tcl_CloseProc) (ClientData data);
+typedef void (Tcl_CmdDeleteProc) (ClientData clientData);
+typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp,
+ int argc, CONST84 char *argv[]);
+typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
+ int level, char *command, Tcl_CmdProc *proc,
+ ClientData cmdClientData, int argc, CONST84 char *argv[]);
+typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
+ int level, const char *command, Tcl_Command commandInfo, int objc,
+ struct Tcl_Obj *const *objv);
+typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData);
+typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
+ struct Tcl_Obj *dupPtr);
+typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src,
+ int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst,
+ int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
+typedef void (Tcl_EncodingFreeProc) (ClientData clientData);
+typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags);
+typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags);
+typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData);
+typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags);
+typedef void (Tcl_ExitProc) (ClientData clientData);
+typedef void (Tcl_FileProc) (ClientData clientData, int mask);
+typedef void (Tcl_FileFreeProc) (ClientData clientData);
+typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr);
+typedef void (Tcl_FreeProc) (char *blockPtr);
+typedef void (Tcl_IdleProc) (ClientData clientData);
+typedef void (Tcl_InterpDeleteProc) (ClientData clientData,
+ Tcl_Interp *interp);
+typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp,
+ Tcl_Value *args, Tcl_Value *resultPtr);
+typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData);
+typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp,
+ int objc, struct Tcl_Obj *const *objv);
+typedef int (Tcl_PackageInitProc) (Tcl_Interp *interp);
+typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags);
+typedef void (Tcl_PanicProc) (const char *format, ...);
+typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan,
+ char *address, int port);
+typedef void (Tcl_TimerProc) (ClientData clientData);
+typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
+typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
+typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
+ CONST84 char *part1, CONST84 char *part2, int flags);
+typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
+ const char *oldName, const char *newName, int flags);
+typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
+ ClientData clientData);
+typedef void (Tcl_DeleteFileHandlerProc) (int fd);
+typedef void (Tcl_AlertNotifierProc) (ClientData clientData);
+typedef void (Tcl_ServiceModeHookProc) (int mode);
+typedef ClientData (Tcl_InitNotifierProc) (void);
+typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData);
+typedef void (Tcl_MainLoopProc) (void);
+
/*
+ *----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
* internal representation for an object plus a set of functions that provide
* standard operations on objects of that type.
*/
typedef struct Tcl_ObjType {
- char *name; /* Name of the type, e.g. "int". */
+ const char *name; /* Name of the type, e.g. "int". */
Tcl_FreeInternalRepProc *freeIntRepProc;
/* Called to free any storage for the type's
* internal rep. NULL if the internal rep does
@@ -757,24 +788,27 @@ typedef struct Tcl_Obj {
* array as a readonly value. */
int length; /* The number of bytes at *bytes, not
* including the terminating null. */
- Tcl_ObjType *typePtr; /* Denotes the object's type. Always
+ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
union { /* The internal representation: */
long longValue; /* - an long integer value. */
double doubleValue; /* - a double-precision floating value. */
- VOID *otherValuePtr; /* - another, type-specific value. */
+ void *otherValuePtr; /* - another, type-specific value. */
Tcl_WideInt wideValue; /* - a long long value. */
struct { /* - internal rep as two pointers. */
- VOID *ptr1;
- VOID *ptr2;
+ void *ptr1;
+ void *ptr2;
} twoPtrValue;
- struct { /* - internal rep as a wide int, tightly
- * packed fields. */
- VOID *ptr; /* Pointer to digits. */
- unsigned long value;/* Alloc, used, and signum packed into a
- * single word. */
+ struct { /* - internal rep as a pointer and a long,
+ * the main use of which is a bignum's
+ * tightly packed fields, where the alloc,
+ * used and signum flags are packed into a
+ * single word with everything else hung
+ * off the pointer. */
+ void *ptr;
+ unsigned long value;
} ptrAndLongRep;
} internalRep;
} Tcl_Obj;
@@ -790,11 +824,12 @@ typedef struct Tcl_Obj {
* to compute or has side effects.
*/
-void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
-void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
-int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
-
+void Tcl_IncrRefCount(Tcl_Obj *objPtr);
+void Tcl_DecrRefCount(Tcl_Obj *objPtr);
+int Tcl_IsShared(Tcl_Obj *objPtr);
+
/*
+ *----------------------------------------------------------------------------
* The following structure contains the state needed by Tcl_SaveResult. No-one
* outside of Tcl should access any of these fields. This structure is
* typically allocated on the stack.
@@ -811,6 +846,7 @@ typedef struct Tcl_SavedResult {
} Tcl_SavedResult;
/*
+ *----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
* five fields must match exactly the fields in a Namespace structure (see
* tclInt.h).
@@ -835,6 +871,7 @@ typedef struct Tcl_Namespace {
} Tcl_Namespace;
/*
+ *----------------------------------------------------------------------------
* The following structure represents a call frame, or activation record. A
* call frame defines a naming context for a procedure call: its local scope
* (for local variables) and its namespace scope (used for non-local
@@ -860,20 +897,21 @@ typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
int dummy2;
- VOID *dummy3;
- VOID *dummy4;
- VOID *dummy5;
+ void *dummy3;
+ void *dummy4;
+ void *dummy5;
int dummy6;
- VOID *dummy7;
- VOID *dummy8;
+ void *dummy7;
+ void *dummy8;
int dummy9;
- VOID *dummy10;
- VOID *dummy11;
- VOID *dummy12;
- VOID *dummy13;
+ void *dummy10;
+ void *dummy11;
+ void *dummy12;
+ void *dummy13;
} Tcl_CallFrame;
/*
+ *----------------------------------------------------------------------------
* Information about commands that is returned by Tcl_GetCommandInfo and
* passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command
* function while proc is a traditional Tcl argc/argv string-based function.
@@ -909,6 +947,7 @@ typedef struct Tcl_CmdInfo {
} Tcl_CmdInfo;
/*
+ *----------------------------------------------------------------------------
* The structure defined below is used to hold dynamic strings. The only
* fields that clients should use are string and length, accessible via the
* macros Tcl_DStringValue and Tcl_DStringLength.
@@ -971,6 +1010,7 @@ typedef struct Tcl_DString {
#define TCL_EXACT 1
/*
+ *----------------------------------------------------------------------------
* Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
* WARNING: these bit choices must not conflict with the bit choices for
* evalFlag bits in tclInt.h!
@@ -984,11 +1024,19 @@ typedef struct Tcl_DString {
* o Cut out of error traces
* o Don't reset the flags controlling ensemble
* error message rewriting.
+ * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the
+ * stack for the script in progress to be
+ * completely unwound.
+ * TCL_EVAL_NOERR: Do no exception reporting at all, just return
+ * as the caller will report.
*/
-#define TCL_NO_EVAL 0x10000
-#define TCL_EVAL_GLOBAL 0x20000
-#define TCL_EVAL_DIRECT 0x40000
-#define TCL_EVAL_INVOKE 0x80000
+
+#define TCL_NO_EVAL 0x010000
+#define TCL_EVAL_GLOBAL 0x020000
+#define TCL_EVAL_DIRECT 0x040000
+#define TCL_EVAL_INVOKE 0x080000
+#define TCL_CANCEL_UNWIND 0x100000
+#define TCL_EVAL_NOERR 0x200000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see the man
@@ -1001,6 +1049,8 @@ typedef struct Tcl_DString {
/*
* Flag values passed to variable-related functions.
+ * WARNING: these bit choices must not conflict with the bit choice for
+ * TCL_CANCEL_UNWIND, above.
*/
#define TCL_GLOBAL_ONLY 1
@@ -1015,10 +1065,10 @@ typedef struct Tcl_DString {
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
-/* Required to support old variable/vdelete/vinfo traces */
+/* Required to support old variable/vdelete/vinfo traces. */
#define TCL_TRACE_OLD_STYLE 0x1000
#endif
-/* Indicate the semantics of the result of a trace */
+/* Indicate the semantics of the result of a trace. */
#define TCL_TRACE_RESULT_DYNAMIC 0x8000
#define TCL_TRACE_RESULT_OBJECT 0x10000
@@ -1034,8 +1084,8 @@ typedef struct Tcl_DString {
* Flag values passed to command-related functions.
*/
-#define TCL_TRACE_RENAME 0x2000
-#define TCL_TRACE_DELETE 0x4000
+#define TCL_TRACE_RENAME 0x2000
+#define TCL_TRACE_DELETE 0x4000
#define TCL_ALLOW_INLINE_COMPILATION 0x20000
@@ -1069,8 +1119,9 @@ typedef struct Tcl_DString {
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
#define TCL_LINK_READ_ONLY 0x80
-
+
/*
+ *----------------------------------------------------------------------------
* Forward declarations of Tcl_HashTable and related types.
*/
@@ -1078,13 +1129,11 @@ typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
-typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- VOID *keyPtr));
-typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
- Tcl_HashEntry *hPtr));
-typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
- Tcl_HashTable *tablePtr, VOID *keyPtr));
-typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));
+typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
+typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr);
+typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr,
+ void *keyPtr);
+typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr);
/*
* This flag controls whether the hash table stores the hash of a key, or
@@ -1108,7 +1157,7 @@ struct Tcl_HashEntry {
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
#if TCL_HASH_KEY_STORE_HASH
- VOID *hash; /* Hash value, stored as pointer to ensure
+ void *hash; /* Hash value, stored as pointer to ensure
* that the offsets of the fields in this
* structure are not changed. */
#else
@@ -1124,7 +1173,7 @@ struct Tcl_HashEntry {
int words[1]; /* Multiple integer words for key. The actual
* size will be as large as necessary for this
* table's keys. */
- char string[4]; /* String for key. The actual size will be as
+ char string[1]; /* String for key. The actual size will be as
* large as needed to hold the key. */
} key; /* MUST BE LAST FIELD IN RECORD!! */
};
@@ -1219,11 +1268,11 @@ struct Tcl_HashTable {
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
- Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key));
- Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr));
- Tcl_HashKeyType *typePtr; /* Type of the keys used in the
+ Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
+ Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key,
+ int *newPtr);
+ const Tcl_HashKeyType *typePtr;
+ /* Type of the keys used in the
* Tcl_HashTable. */
};
@@ -1261,10 +1310,10 @@ typedef struct Tcl_HashSearch {
* accessed from the entry and not the behaviour.
*/
-#define TCL_STRING_KEYS 0
-#define TCL_ONE_WORD_KEYS 1
-#define TCL_CUSTOM_TYPE_KEYS -2
-#define TCL_CUSTOM_PTR_KEYS -1
+#define TCL_STRING_KEYS (0)
+#define TCL_ONE_WORD_KEYS (1)
+#define TCL_CUSTOM_TYPE_KEYS (-2)
+#define TCL_CUSTOM_PTR_KEYS (-1)
/*
* Structure definition for information used to keep track of searches through
@@ -1279,8 +1328,9 @@ typedef struct {
* or -1 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
-
+
/*
+ *----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
* events:
*/
@@ -1333,19 +1383,18 @@ typedef struct Tcl_Time {
long usec; /* Microseconds. */
} Tcl_Time;
-typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
-typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));
+typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr);
+typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr);
/*
* TIP #233 (Virtualized Time)
*/
-typedef void (Tcl_GetTimeProc) _ANSI_ARGS_((Tcl_Time *timebuf,
- ClientData clientData));
-typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_((Tcl_Time *timebuf,
- ClientData clientData));
+typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData);
+typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
/*
+ *----------------------------------------------------------------------------
* Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to
* indicate what sorts of events are of interest:
*/
@@ -1401,45 +1450,41 @@ typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_((Tcl_Time *timebuf,
* Typedefs for the various operations in a channel type:
*/
-typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
- ClientData instanceData, int mode));
-typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp));
-typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, int flags));
-typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCodePtr));
-typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
- CONST84 char *buf, int toWrite, int *errorCodePtr));
-typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
- long offset, int mode, int *errorCodePtr));
-typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
- ClientData instanceData, Tcl_Interp *interp,
- CONST char *optionName, CONST char *value));
-typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
- ClientData instanceData, Tcl_Interp *interp,
- CONST84 char *optionName, Tcl_DString *dsPtr));
-typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_((
- ClientData instanceData, int mask));
-typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
- ClientData instanceData, int direction,
- ClientData *handlePtr));
-typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((ClientData instanceData));
-typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_((
- ClientData instanceData, int interestMask));
-typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
- ClientData instanceData, Tcl_WideInt offset,
- int mode, int *errorCodePtr));
+typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode);
+typedef int (Tcl_DriverCloseProc) (ClientData instanceData,
+ Tcl_Interp *interp);
+typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
+ Tcl_Interp *interp, int flags);
+typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
+ int toRead, int *errorCodePtr);
+typedef int (Tcl_DriverOutputProc) (ClientData instanceData,
+ CONST84 char *buf, int toWrite, int *errorCodePtr);
+typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset,
+ int mode, int *errorCodePtr);
+typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
+ Tcl_Interp *interp, const char *optionName,
+ const char *value);
+typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
+ Tcl_Interp *interp, CONST84 char *optionName,
+ Tcl_DString *dsPtr);
+typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask);
+typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData,
+ int direction, ClientData *handlePtr);
+typedef int (Tcl_DriverFlushProc) (ClientData instanceData);
+typedef int (Tcl_DriverHandlerProc) (ClientData instanceData,
+ int interestMask);
+typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData,
+ Tcl_WideInt offset, int mode, int *errorCodePtr);
/*
* TIP #218, Channel Thread Actions
*/
-typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ ((
- ClientData instanceData, int action));
+typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData,
+ int action);
/*
* TIP #208, File Truncation (etc.)
*/
-typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_((
- ClientData instanceData, Tcl_WideInt length));
+typedef int (Tcl_DriverTruncateProc) (ClientData instanceData,
+ Tcl_WideInt length);
/*
* struct Tcl_ChannelType:
@@ -1453,7 +1498,7 @@ typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_((
*/
typedef struct Tcl_ChannelType {
- char *typeName; /* The name of the channel type in Tcl
+ const char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by channel
* type. */
Tcl_ChannelTypeVersion version;
@@ -1512,7 +1557,6 @@ typedef struct Tcl_ChannelType {
/* Function to call to notify the driver of
* thread specific activity for a channel. May
* be NULL. */
-
/*
* Only valid in TCL_CHANNEL_VERSION_5 channels or later.
* TIP #208, File Truncation.
@@ -1534,6 +1578,7 @@ typedef struct Tcl_ChannelType {
* mode. */
/*
+ *----------------------------------------------------------------------------
* Enum for different types of file paths.
*/
@@ -1585,71 +1630,60 @@ typedef struct Tcl_GlobTypeData {
* Typedefs for the various filesystem operations:
*/
-typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
-typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
-typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions));
-typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern,
- Tcl_GlobTypeData * types));
-typedef Tcl_Obj * (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
-typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
-typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
- Tcl_StatBuf *buf));
-typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
-typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
-typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
- Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
-typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
- Tcl_Obj *destPathPtr));
-typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
- int recursive, Tcl_Obj **errorPtr));
-typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
- Tcl_Obj *destPathPtr));
-typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
-typedef Tcl_Obj * (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
+typedef int (Tcl_FSStatProc) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+typedef int (Tcl_FSAccessProc) (Tcl_Obj *pathPtr, int mode);
+typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) (Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int mode, int permissions);
+typedef int (Tcl_FSMatchInDirectoryProc) (Tcl_Interp *interp, Tcl_Obj *result,
+ Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types);
+typedef Tcl_Obj * (Tcl_FSGetCwdProc) (Tcl_Interp *interp);
+typedef int (Tcl_FSChdirProc) (Tcl_Obj *pathPtr);
+typedef int (Tcl_FSLstatProc) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+typedef int (Tcl_FSCreateDirectoryProc) (Tcl_Obj *pathPtr);
+typedef int (Tcl_FSDeleteFileProc) (Tcl_Obj *pathPtr);
+typedef int (Tcl_FSCopyDirectoryProc) (Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr);
+typedef int (Tcl_FSCopyFileProc) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr);
+typedef int (Tcl_FSRemoveDirectoryProc) (Tcl_Obj *pathPtr, int recursive,
+ Tcl_Obj **errorPtr);
+typedef int (Tcl_FSRenameFileProc) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr);
+typedef void (Tcl_FSUnloadFileProc) (Tcl_LoadHandle loadHandle);
+typedef Tcl_Obj * (Tcl_FSListVolumesProc) (void);
/* We have to declare the utime structure here. */
struct utimbuf;
-typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
- struct utimbuf *tval));
-typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *pathPtr, int nextCheckpoint));
-typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef));
-typedef CONST char ** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((
- Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef));
-typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr));
-typedef Tcl_Obj * (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
- Tcl_Obj *toPtr, int linkType));
-typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr,
- Tcl_FSUnloadFileProc **unloadProcPtr));
-typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
- ClientData *clientDataPtr));
-typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) _ANSI_ARGS_((
- Tcl_Obj *pathPtr));
-typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) _ANSI_ARGS_((
- Tcl_Obj *pathPtr));
-typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
-typedef ClientData (Tcl_FSDupInternalRepProc) _ANSI_ARGS_((
- ClientData clientData));
-typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) _ANSI_ARGS_((
- ClientData clientData));
-typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((
- Tcl_Obj *pathPtr));
+typedef int (Tcl_FSUtimeProc) (Tcl_Obj *pathPtr, struct utimbuf *tval);
+typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int nextCheckpoint);
+typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
+typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef);
+typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
+typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
+ int linkType);
+typedef int (Tcl_FSLoadFileProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr);
+typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr);
+typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr);
+typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr);
+typedef void (Tcl_FSFreeInternalRepProc) (ClientData clientData);
+typedef ClientData (Tcl_FSDupInternalRepProc) (ClientData clientData);
+typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (ClientData clientData);
+typedef ClientData (Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr);
typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
/*
- *----------------------------------------------------------------
+ *----------------------------------------------------------------------------
* Data structures related to hooking into the filesystem
- *----------------------------------------------------------------
*/
/*
* Filesystem version tag. This was introduced in 8.4.
*/
+
#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
/*
@@ -1666,7 +1700,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
*/
typedef struct Tcl_Filesystem {
- CONST char *typeName; /* The name of the filesystem. */
+ const char *typeName; /* The name of the filesystem. */
int structureLength; /* Length of this structure, so future binary
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
@@ -1828,6 +1862,7 @@ typedef struct Tcl_Filesystem {
#define TCL_CREATE_HARD_LINK 0x02
/*
+ *----------------------------------------------------------------------------
* The following structure represents the Notifier functions that you can
* override with the Tcl_SetNotifier call.
*/
@@ -1842,73 +1877,11 @@ typedef struct Tcl_NotifierProcs {
Tcl_AlertNotifierProc *alertNotifierProc;
Tcl_ServiceModeHookProc *serviceModeHookProc;
} Tcl_NotifierProcs;
-
-/*
- * The following structure represents a user-defined encoding. It collects
- * together all the functions that are used by the specific encoding.
- */
-
-typedef struct Tcl_EncodingType {
- CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp".
- * This name is the unique key for this
- * encoding type. */
- Tcl_EncodingConvertProc *toUtfProc;
- /* Function to convert from external encoding
- * into UTF-8. */
- Tcl_EncodingConvertProc *fromUtfProc;
- /* Function to convert from UTF-8 into
- * external encoding. */
- Tcl_EncodingFreeProc *freeProc;
- /* If non-NULL, function to call when this
- * encoding is deleted. */
- ClientData clientData; /* Arbitrary value associated with encoding
- * type. Passed to conversion functions. */
- int nullSize; /* Number of zero bytes that signify
- * end-of-string in this encoding. This number
- * is used to determine the source string
- * length when the srcLen argument is
- * negative. Must be 1 or 2. */
-} Tcl_EncodingType;
-
-/*
- * The following definitions are used as values for the conversion control
- * flags argument when converting text from one character set to another:
- *
- * TCL_ENCODING_START - Signifies that the source buffer is the first
- * block in a (potentially multi-block) input
- * stream. Tells the conversion function to reset
- * to an initial state and perform any
- * initialization that needs to occur before the
- * first byte is converted. If the source buffer
- * contains the entire input stream to be
- * converted, this flag should be set.
- * TCL_ENCODING_END - Signifies that the source buffer is the last
- * block in a (potentially multi-block) input
- * stream. Tells the conversion routine to
- * perform any finalization that needs to occur
- * after the last byte is converted and then to
- * reset to an initial state. If the source
- * buffer contains the entire input stream to be
- * converted, this flag should be set.
- * TCL_ENCODING_STOPONERROR - If set, then the converter will return
- * immediately upon encountering an invalid byte
- * sequence or a source character that has no
- * mapping in the target encoding. If clear, then
- * the converter will skip the problem,
- * substituting one or more "close" characters in
- * the destination buffer and then continue to
- * convert the source.
- */
-
-#define TCL_ENCODING_START 0x01
-#define TCL_ENCODING_END 0x02
-#define TCL_ENCODING_STOPONERROR 0x04
-
+
/*
+ *----------------------------------------------------------------------------
* The following data structures and declarations are for the new Tcl parser.
- */
-
-/*
+ *
* For each word of a command, and for each piece of a word such as a variable
* reference, one of the following structures is created to describe the
* token.
@@ -1917,7 +1890,7 @@ typedef struct Tcl_EncodingType {
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
- CONST char *start; /* First character in token. */
+ const char *start; /* First character in token. */
int size; /* Number of bytes in token. */
int numComponents; /* If this token is composed of other tokens,
* this field tells how many of them there are
@@ -2031,13 +2004,13 @@ typedef struct Tcl_Token {
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
- CONST char *commentStart; /* Pointer to # that begins the first of one
+ const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
int commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
- CONST char *commandStart; /* First character in first word of
+ const char *commandStart; /* First character in first word of
* command. */
int commandSize; /* Number of bytes in command, including first
* character of first word, up through the
@@ -2061,13 +2034,13 @@ typedef struct Tcl_Parse {
* They should not be used by functions that invoke Tcl_ParseCommand.
*/
- CONST char *string; /* The original command string passed to
+ const char *string; /* The original command string passed to
* Tcl_ParseCommand. */
- CONST char *end; /* Points to the character just after the last
+ const char *end; /* Points to the character just after the last
* one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting, or
* NULL. */
- CONST char *term; /* Points to character in string that
+ const char *term; /* Points to character in string that
* terminated most recent token. Filled in by
* ParseTokens. If an error occurs, points to
* beginning of region where the error
@@ -2084,6 +2057,68 @@ typedef struct Tcl_Parse {
* for very large commands that don't fit
* here. */
} Tcl_Parse;
+
+/*
+ *----------------------------------------------------------------------------
+ * The following structure represents a user-defined encoding. It collects
+ * together all the functions that are used by the specific encoding.
+ */
+
+typedef struct Tcl_EncodingType {
+ const char *encodingName; /* The name of the encoding, e.g. "euc-jp".
+ * This name is the unique key for this
+ * encoding type. */
+ Tcl_EncodingConvertProc *toUtfProc;
+ /* Function to convert from external encoding
+ * into UTF-8. */
+ Tcl_EncodingConvertProc *fromUtfProc;
+ /* Function to convert from UTF-8 into
+ * external encoding. */
+ Tcl_EncodingFreeProc *freeProc;
+ /* If non-NULL, function to call when this
+ * encoding is deleted. */
+ ClientData clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion functions. */
+ int nullSize; /* Number of zero bytes that signify
+ * end-of-string in this encoding. This number
+ * is used to determine the source string
+ * length when the srcLen argument is
+ * negative. Must be 1 or 2. */
+} Tcl_EncodingType;
+
+/*
+ * The following definitions are used as values for the conversion control
+ * flags argument when converting text from one character set to another:
+ *
+ * TCL_ENCODING_START - Signifies that the source buffer is the first
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion function to reset
+ * to an initial state and perform any
+ * initialization that needs to occur before the
+ * first byte is converted. If the source buffer
+ * contains the entire input stream to be
+ * converted, this flag should be set.
+ * TCL_ENCODING_END - Signifies that the source buffer is the last
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion routine to
+ * perform any finalization that needs to occur
+ * after the last byte is converted and then to
+ * reset to an initial state. If the source
+ * buffer contains the entire input stream to be
+ * converted, this flag should be set.
+ * TCL_ENCODING_STOPONERROR - If set, then the converter will return
+ * immediately upon encountering an invalid byte
+ * sequence or a source character that has no
+ * mapping in the target encoding. If clear, then
+ * the converter will skip the problem,
+ * substituting one or more "close" characters in
+ * the destination buffer and then continue to
+ * convert the source.
+ */
+
+#define TCL_ENCODING_START 0x01
+#define TCL_ENCODING_END 0x02
+#define TCL_ENCODING_STOPONERROR 0x04
/*
* The following definitions are the error codes returned by the conversion
@@ -2113,10 +2148,10 @@ typedef struct Tcl_Parse {
* TCL_ENCODING_STOPONERROR was specified.
*/
-#define TCL_CONVERT_MULTIBYTE -1
-#define TCL_CONVERT_SYNTAX -2
-#define TCL_CONVERT_UNKNOWN -3
-#define TCL_CONVERT_NOSPACE -4
+#define TCL_CONVERT_MULTIBYTE (-1)
+#define TCL_CONVERT_SYNTAX (-2)
+#define TCL_CONVERT_UNKNOWN (-3)
+#define TCL_CONVERT_NOSPACE (-4)
/*
* The maximum number of bytes that are necessary to represent a single
@@ -2151,20 +2186,22 @@ typedef unsigned int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
-
+
/*
+ *----------------------------------------------------------------------------
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
* provide the system with the embedded configuration data.
*/
typedef struct Tcl_Config {
- CONST char *key; /* Configuration key to register. ASCII
+ const char *key; /* Configuration key to register. ASCII
* encoded, thus UTF-8. */
- CONST char *value; /* The value associated with the key. System
+ const char *value; /* The value associated with the key. System
* encoding. */
} Tcl_Config;
/*
+ *----------------------------------------------------------------------------
* Flags for TIP#143 limits, detailing which limits are active in an
* interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument.
*/
@@ -2177,9 +2214,13 @@ typedef struct Tcl_Config {
* command- or time-limit is exceeded by an interpreter.
*/
-typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp));
-typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp);
+typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData);
+
+/*
+ *----------------------------------------------------------------------------
+ * Override definitions for libtommath.
+ */
typedef struct mp_int mp_int;
#define MP_INT_DECLARED
@@ -2187,6 +2228,114 @@ typedef unsigned int mp_digit;
#define MP_DIGIT_DECLARED
/*
+ *----------------------------------------------------------------------------
+ * Definitions needed for Tcl_ParseArgvObj routines.
+ * Based on tkArgv.c.
+ * Modifications from the original are copyright (c) Sam Bromley 2006
+ */
+
+typedef struct {
+ int type; /* Indicates the option type; see below. */
+ const char *keyStr; /* The key string that flags the option in the
+ * argv array. */
+ void *srcPtr; /* Value to be used in setting dst; usage
+ * depends on type.*/
+ void *dstPtr; /* Address of value to be modified; usage
+ * depends on type.*/
+ const char *helpStr; /* Documentation message describing this
+ * option. */
+ ClientData clientData; /* Word to pass to function callbacks. */
+} Tcl_ArgvInfo;
+
+/*
+ * Legal values for the type field of a Tcl_ArgInfo: see the user
+ * documentation for details.
+ */
+
+#define TCL_ARGV_CONSTANT 15
+#define TCL_ARGV_INT 16
+#define TCL_ARGV_STRING 17
+#define TCL_ARGV_REST 18
+#define TCL_ARGV_FLOAT 19
+#define TCL_ARGV_FUNC 20
+#define TCL_ARGV_GENFUNC 21
+#define TCL_ARGV_HELP 22
+#define TCL_ARGV_END 23
+
+/*
+ * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC
+ * argument types:
+ */
+
+typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr,
+ void *dstPtr);
+typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv, void *dstPtr);
+
+/*
+ * Shorthand for commonly used argTable entries.
+ */
+
+#define TCL_ARGV_AUTO_HELP \
+ {TCL_ARGV_HELP, "-help", NULL, NULL, \
+ "Print summary of command-line options and abort"}
+#define TCL_ARGV_AUTO_REST \
+ {TCL_ARGV_REST, "--", NULL, NULL, \
+ "Marks the end of the options"}
+#define TCL_ARGV_TABLE_END \
+ {TCL_ARGV_END}
+
+/*
+ *----------------------------------------------------------------------------
+ * Definitions needed for Tcl_Zlib routines. [TIP #234]
+ *
+ * Constants for the format flags describing what sort of data format is
+ * desired/expected for the Tcl_ZlibDeflate, Tcl_ZlibInflate and
+ * Tcl_ZlibStreamInit functions.
+ */
+
+#define TCL_ZLIB_FORMAT_RAW 1
+#define TCL_ZLIB_FORMAT_ZLIB 2
+#define TCL_ZLIB_FORMAT_GZIP 4
+#define TCL_ZLIB_FORMAT_AUTO 8
+
+/*
+ * Constants that describe whether the stream is to operate in compressing or
+ * decompressing mode.
+ */
+
+#define TCL_ZLIB_STREAM_DEFLATE 16
+#define TCL_ZLIB_STREAM_INFLATE 32
+
+/*
+ * Constants giving compression levels. Use of TCL_ZLIB_COMPRESS_DEFAULT is
+ * recommended.
+ */
+
+#define TCL_ZLIB_COMPRESS_NONE 0
+#define TCL_ZLIB_COMPRESS_FAST 1
+#define TCL_ZLIB_COMPRESS_BEST 9
+#define TCL_ZLIB_COMPRESS_DEFAULT (-1)
+
+/*
+ * Constants for types of flushing, used with Tcl_ZlibFlush.
+ */
+
+#define TCL_ZLIB_NO_FLUSH 0
+#define TCL_ZLIB_FLUSH 2
+#define TCL_ZLIB_FULLFLUSH 3
+#define TCL_ZLIB_FINALIZE 4
+
+/*
+ *----------------------------------------------------------------------------
+ * Single public declaration for NRE.
+ */
+
+typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
+ int result);
+
+/*
+ *----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
*
@@ -2203,42 +2352,39 @@ typedef unsigned int mp_digit;
* main library in case an extension is statically linked into an application.
*/
-EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *version, int exact));
-EXTERN CONST char * TclTomMathInitializeStubs _ANSI_ARGS_((
- Tcl_Interp *interp, CONST char *version,
- int epoch, int revision));
-
-#ifndef USE_TCL_STUBS
+const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
+ int exact);
+const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
+ const char *version, int epoch, int revision);
/*
* When not using stubs, make it a macro.
*/
+#ifndef USE_TCL_STUBS
#define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, version, exact)
-
#endif
- /*
- * TODO - tommath stubs export goes here!
- */
-
+/*
+ * TODO - tommath stubs export goes here!
+ */
/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
*/
-EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
- Tcl_AppInitProc *appInitProc));
-EXTERN CONST char * Tcl_PkgInitStubsCheck _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *version, int exact));
+EXTERN void Tcl_Main(int argc, char **argv,
+ Tcl_AppInitProc *appInitProc);
+EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
+ const char *version, int exact);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
+EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#endif
-
+
/*
+ *----------------------------------------------------------------------------
* Include the public function declarations that are accessible via the stubs
* table.
*/
@@ -2253,6 +2399,7 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#include "tclPlatDecls.h"
/*
+ *----------------------------------------------------------------------------
* The following declarations either map ckalloc and ckfree to malloc and
* free, or they map them to functions with all sorts of debugging hooks
* defined in tclCkalloc.c.
@@ -2260,11 +2407,16 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#ifdef TCL_MEM_DEBUG
-# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
-# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
-# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
-# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
-# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)
+# define ckalloc(x) \
+ ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
+# define ckfree(x) \
+ Tcl_DbCkfree((char *)(x), __FILE__, __LINE__)
+# define ckrealloc(x,y) \
+ ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
+# define attemptckalloc(x) \
+ ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
+# define attemptckrealloc(x,y) \
+ ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
#else /* !TCL_MEM_DEBUG */
@@ -2274,11 +2426,16 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
* memory allocator both inside and outside of the Tcl library.
*/
-# define ckalloc(x) Tcl_Alloc(x)
-# define ckfree(x) Tcl_Free(x)
-# define ckrealloc(x,y) Tcl_Realloc(x,y)
-# define attemptckalloc(x) Tcl_AttemptAlloc(x)
-# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
+# define ckalloc(x) \
+ ((VOID *) Tcl_Alloc((unsigned)(x)))
+# define ckfree(x) \
+ Tcl_Free((char *)(x))
+# define ckrealloc(x,y) \
+ ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y)))
+# define attemptckalloc(x) \
+ ((VOID *) Tcl_AttemptAlloc((unsigned)(x)))
+# define attemptckrealloc(x,y) \
+ ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y)))
# undef Tcl_InitMemory
# define Tcl_InitMemory(x)
# undef Tcl_DumpActiveMemory
@@ -2348,13 +2505,14 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#endif /* TCL_MEM_DEBUG */
/*
+ *----------------------------------------------------------------------------
* Macros for clients to use to access fields of hash entries:
*/
#define Tcl_GetHashValue(h) ((h)->clientData)
#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
#define Tcl_GetHashKey(tablePtr, h) \
- ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
+ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
(tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
? (h)->key.oneWordValue \
: (h)->key.string))
@@ -2366,12 +2524,13 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#undef Tcl_FindHashEntry
#define Tcl_FindHashEntry(tablePtr, key) \
- (*((tablePtr)->findProc))(tablePtr, key)
+ (*((tablePtr)->findProc))(tablePtr, (const char *)(key))
#undef Tcl_CreateHashEntry
#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
- (*((tablePtr)->createProc))(tablePtr, key, newPtr)
+ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr)
/*
+ *----------------------------------------------------------------------------
* Macros that eliminate the overhead of the thread synchronization functions
* when compiling without thread support.
*/
@@ -2391,11 +2550,12 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */
-#ifndef TCL_NO_DEPRECATED
- /*
- * Deprecated Tcl functions:
- */
+/*
+ *----------------------------------------------------------------------------
+ * Deprecated Tcl functions:
+ */
+#ifndef TCL_NO_DEPRECATED
# undef Tcl_EvalObj
# define Tcl_EvalObj(interp,objPtr) \
Tcl_EvalObjEx((interp),(objPtr),0)
@@ -2403,10 +2563,10 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
# 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.
- */
+/*
+ * These function have been renamed. The old names are deprecated, but we
+ * define these macros for backwards compatibilty.
+ */
# define Tcl_Ckalloc Tcl_Alloc
# define Tcl_Ckfree Tcl_Free
@@ -2415,21 +2575,16 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
# define Tcl_TildeSubst Tcl_TranslateFileName
# define panic Tcl_Panic
# define panicVA Tcl_PanicVA
-#endif
+#endif /* !TCL_NO_DEPRECATED */
/*
+ *----------------------------------------------------------------------------
* Convenience declaration of Tcl_AppInit for backwards compatibility. This
* function is not *implemented* by the tcl library, so the storage class is
* neither DLLEXPORT nor DLLIMPORT.
*/
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS
-
-EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
+extern Tcl_AppInitProc Tcl_AppInit;
#endif /* RC_INVOKED */
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 7647b4d..6fff92b 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -78,7 +78,7 @@ union overhead {
#define RMAGIC 0x5555 /* magic # on range info */
#ifdef RCHECK
-#define RSLOP sizeof (unsigned short)
+#define RSLOP sizeof(unsigned short)
#else
#define RSLOP 0
#endif
@@ -140,7 +140,6 @@ static int allocInit = 0;
*/
static unsigned int numMallocs[NBUCKETS+1];
-#include <stdio.h>
#endif
#if defined(DEBUG) || defined(RCHECK)
@@ -155,7 +154,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
-static void MoreCore(int bucket);
+static void MoreCore(int bucket);
/*
*-------------------------------------------------------------------------
@@ -464,7 +463,7 @@ TclpFree(
}
Tcl_MutexLock(allocMutexPtr);
- overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead));
+ overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead));
ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */
ASSERT(overPtr->overMagic1 == MAGIC);
@@ -533,7 +532,7 @@ TclpRealloc(
Tcl_MutexLock(allocMutexPtr);
- overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead));
+ overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead));
ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */
ASSERT(overPtr->overMagic1 == MAGIC);
@@ -703,7 +702,7 @@ char *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
- return (char*) malloc(numBytes);
+ return (char *) malloc(numBytes);
}
/*
@@ -751,7 +750,7 @@ TclpRealloc(
char *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
- return (char*) realloc(oldPtr, numBytes);
+ return (char *) realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
new file mode 100644
index 0000000..754941f
--- /dev/null
+++ b/generic/tclAssembly.c
@@ -0,0 +1,4310 @@
+/*
+ * tclAssembly,c --
+ *
+ * Assembler for Tcl bytecodes.
+ *
+ * This file contains the procedures that convert Tcl Assembly Language (TAL)
+ * to a sequence of bytecode instructions for the Tcl execution engine.
+ *
+ * Copyright (c) 2010 by Ozgur Dogan Ugurlu.
+ * Copyright (c) 2010 by Kevin B. Kenny.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+/*-
+ *- THINGS TO DO:
+ *- More instructions:
+ *- done - alternate exit point (affects stack and exception range checking)
+ *- break and continue - if exception ranges can be sorted out.
+ *- foreach_start4, foreach_step4
+ *- returnImm, returnStk
+ *- expandStart, expandStkTop, invokeExpanded
+ *- dictFirst, dictNext, dictDone
+ *- dictUpdateStart, dictUpdateEnd
+ *- jumpTable testing
+ *- syntax (?)
+ *- returnCodeBranch
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include "tclOOInt.h"
+
+/*
+ * Structure that represents a range of instructions in the bytecode.
+ */
+
+typedef struct CodeRange {
+ int startOffset; /* Start offset in the bytecode array */
+ int endOffset; /* End offset in the bytecode array */
+} CodeRange;
+
+/*
+ * State identified for a basic block's catch context.
+ */
+
+typedef enum BasicBlockCatchState {
+ BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
+ BBCS_NONE, /* Block is outside of any catch */
+ BBCS_INCATCH, /* Block is within a catch context */
+ BBCS_CAUGHT, /* Block is within a catch context and
+ * may be executed after an exception fires */
+} BasicBlockCatchState;
+
+/*
+ * Structure that defines a basic block - a linear sequence of bytecode
+ * instructions with no jumps in or out (including not changing the
+ * state of any exception range).
+ */
+
+typedef struct BasicBlock {
+ int originalStartOffset; /* Instruction offset before JUMP1s were
+ * substituted with JUMP4's */
+ int startOffset; /* Instruction offset of the start of the
+ * block */
+ int startLine; /* Line number in the input script of the
+ * instruction at the start of the block */
+ int jumpOffset; /* Bytecode offset of the 'jump' instruction
+ * that ends the block, or -1 if there is no
+ * jump. */
+ int jumpLine; /* Line number in the input script of the
+ * 'jump' instruction that ends the block, or
+ * -1 if there is no jump */
+ struct BasicBlock* prevPtr; /* Immediate predecessor of this block */
+ struct BasicBlock* predecessor;
+ /* Predecessor of this block in the spanning
+ * tree */
+ struct BasicBlock* successor1;
+ /* BasicBlock structure of the following
+ * block: NULL at the end of the bytecode
+ * sequence. */
+ Tcl_Obj* jumpTarget; /* Jump target label if the jump target is
+ * unresolved */
+ int initialStackDepth; /* Absolute stack depth on entry */
+ int minStackDepth; /* Low-water relative stack depth */
+ int maxStackDepth; /* High-water relative stack depth */
+ int finalStackDepth; /* Relative stack depth on exit */
+ enum BasicBlockCatchState catchState;
+ /* State of the block for 'catch' analysis */
+ int catchDepth; /* Number of nested catches in which the basic
+ * block appears */
+ struct BasicBlock* enclosingCatch;
+ /* BasicBlock structure of the last startCatch
+ * executed on a path to this block, or NULL
+ * if there is no enclosing catch */
+ int foreignExceptionBase; /* Base index of foreign exceptions */
+ int foreignExceptionCount; /* Count of foreign exceptions */
+ ExceptionRange* foreignExceptions;
+ /* ExceptionRange structures for exception
+ * ranges belonging to embedded scripts and
+ * expressions in this block */
+ JumptableInfo* jtPtr; /* Jump table at the end of this basic block */
+ int flags; /* Boolean flags */
+} BasicBlock;
+
+/*
+ * Flags that pertain to a basic block.
+ */
+
+enum BasicBlockFlags {
+ BB_VISITED = (1 << 0), /* Block has been visited in the current
+ * traversal */
+ BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a
+ * successor */
+ BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump
+ * and may need expansion */
+ BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */
+ BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction,
+ * marking it as the start of a 'catch'
+ * sequence. The 'jumpTarget' is the exception
+ * exit from the catch block. */
+ BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction,
+ * unwinding the catch from the exception
+ * stack. */
+};
+
+/*
+ * Source instruction type recognized by the assembler.
+ */
+
+typedef enum TalInstType {
+ ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
+ ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be
+ * converted to appropriate exception
+ * ranges */
+ ASSEM_BOOL, /* One Boolean operand */
+ ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */
+ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must
+ * be strictly positive, consumes N, produces
+ * 1 */
+ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1
+ * operands, produces 1, N > 0 */
+ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes
+ * N+1 operands, produces 1, N > 0 */
+ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes
+ * N operands, produces 1, N > 0 */
+ ASSEM_END_CATCH, /* End catch. No args. Exception range popped
+ * from stack and stack pointer restored. */
+ ASSEM_EVAL, /* 'eval' - evaluate a constant script (by
+ * compiling it in line with the assembly
+ * code! I love Tcl!) */
+ ASSEM_INDEX, /* 4 byte operand, integer or end-integer */
+ ASSEM_INVOKE, /* 1- or 4-byte operand count, must be
+ * strictly positive, consumes N, produces
+ * 1. */
+ ASSEM_JUMP, /* Jump instructions */
+ ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */
+ ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */
+ ASSEM_LABEL, /* The assembly directive that defines a
+ * label */
+ ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly
+ * positive, consumes N, produces 1 */
+ ASSEM_LIST, /* 4-byte operand count, must be nonnegative,
+ * consumses N, produces 1 */
+ ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3,
+ * consumes N, produces 1 */
+ ASSEM_LVT, /* One operand that references a local
+ * variable */
+ ASSEM_LVT1, /* One 1-byte operand that references a local
+ * variable */
+ ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local
+ * variable, one signed-integer 1-byte
+ * operand */
+ ASSEM_LVT4, /* One 4-byte operand that references a local
+ * variable */
+ ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1,
+ * produces N+2 */
+ ASSEM_PUSH, /* one literal operand */
+ ASSEM_REGEXP, /* One Boolean operand, but weird mapping to
+ * call flags */
+ ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N,
+ * produces N */
+ ASSEM_SINT1, /* One 1-byte signed-integer operand
+ * (INCR_STK_IMM) */
+ ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
+ * LVT entry. Fixed arity */
+} TalInstType;
+
+/*
+ * Description of an instruction recognized by the assembler.
+ */
+
+typedef struct TalInstDesc {
+ const char *name; /* Name of instruction. */
+ TalInstType instType; /* The type of instruction */
+ int tclInstCode; /* Instruction code. For instructions having
+ * 1- and 4-byte variables, tclInstCode is
+ * ((1byte)<<8) || (4byte) */
+ int operandsConsumed; /* Number of operands consumed by the
+ * operation, or INT_MIN if the operation is
+ * variadic */
+ int operandsProduced; /* Number of operands produced by the
+ * operation. If negative, the operation has a
+ * net stack effect of -1-operandsProduced */
+} TalInstDesc;
+
+/*
+ * Structure that holds the state of the assembler while generating code.
+ */
+
+typedef struct AssemblyEnv {
+ CompileEnv* envPtr; /* Compilation environment being used for code
+ * generation */
+ Tcl_Parse* parsePtr; /* Parse of the current line of source */
+ Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose
+ * values are 'label' objects storing the code
+ * offsets of the labels. */
+ int cmdLine; /* Current line number within the assembly
+ * code */
+ int* clNext; /* Invisible continuation line for
+ * [info frame] */
+ BasicBlock* head_bb; /* First basic block in the code */
+ BasicBlock* curr_bb; /* Current basic block */
+ int maxDepth; /* Maximum stack depth encountered */
+ int curCatchDepth; /* Current depth of catches */
+ int maxCatchDepth; /* Maximum depth of catches encountered */
+ int flags; /* Compilation flags (TCL_EVAL_DIRECT) */
+} AssemblyEnv;
+
+/*
+ * Static functions defined in this file.
+ */
+
+static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*,
+ BasicBlock*);
+static BasicBlock * AllocBB(AssemblyEnv*);
+static int AssembleOneLine(AssemblyEnv* envPtr);
+static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed,
+ int produced);
+static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx,
+ int count);
+static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
+ int opnd, int count);
+static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
+ int opnd, int count);
+static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
+ int param, int count);
+static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
+ int count);
+static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
+static int CalculateJumpRelocations(AssemblyEnv*, int*);
+static int CheckForUnclosedCatches(AssemblyEnv*);
+static int CheckForThrowInWrongContext(AssemblyEnv*);
+static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
+static int BytecodeMightThrow(unsigned char);
+static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
+static int CheckNamespaceQualifiers(Tcl_Interp*, const char*,
+ int);
+static int CheckNonNegative(Tcl_Interp*, int);
+static int CheckOneByte(Tcl_Interp*, int);
+static int CheckSignedOneByte(Tcl_Interp*, int);
+static int CheckStack(AssemblyEnv*);
+static int CheckStrictlyPositive(Tcl_Interp*, int);
+static ByteCode * CompileAssembleObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
+ TalInstDesc*);
+static int DefineLabel(AssemblyEnv* envPtr, const char* label);
+static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
+static void DupAssembleCodeInternalRep(Tcl_Obj* src,
+ Tcl_Obj* dest);
+static void FillInJumpOffsets(AssemblyEnv*);
+static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
+ Tcl_Obj* jumpTable);
+static int FindLocalVar(AssemblyEnv* envPtr,
+ Tcl_Token** tokenPtrPtr);
+static int FinishAssembly(AssemblyEnv*);
+static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
+static void FreeAssemblyEnv(AssemblyEnv*);
+static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
+static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
+static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*);
+static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**);
+static void LookForFreshCatches(BasicBlock*, BasicBlock**);
+static void MoveCodeForJumps(AssemblyEnv*, int);
+static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int,
+ int);
+static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int);
+static int ProcessCatches(AssemblyEnv*);
+static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*,
+ BasicBlock*, enum BasicBlockCatchState, int);
+static void ResetVisitedBasicBlocks(AssemblyEnv*);
+static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*);
+static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*,
+ Tcl_Obj*);
+static void RestoreEmbeddedExceptionRanges(AssemblyEnv*);
+static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *,
+ BasicBlock *, int);
+static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough,
+ Tcl_Obj* jumpLabel);
+/* static int AdvanceIp(const unsigned char *pc); */
+static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *,
+ BasicBlock *, int);
+static int StackCheckExit(AssemblyEnv*);
+static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int,
+ BasicBlock**, int*);
+static void SyncStackDepth(AssemblyEnv*);
+static int TclAssembleCode(CompileEnv* envPtr, const char* code,
+ int codeLen, int flags);
+static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
+ BasicBlock**, int*);
+
+/*
+ * Tcl_ObjType that describes bytecode emitted by the assembler.
+ */
+
+static const Tcl_ObjType assembleCodeType = {
+ "assemblecode",
+ FreeAssembleCodeInternalRep, /* freeIntRepProc */
+ DupAssembleCodeInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
+
+/*
+ * 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)
+ */
+
+TalInstDesc TalInstructionTable[] = {
+ /* PUSH must be first, see the code near the end of TclAssembleCode */
+ {"push", ASSEM_PUSH, (INST_PUSH1<<8
+ | INST_PUSH4), 0, 1},
+
+ {"add", ASSEM_1BYTE, INST_ADD, 2, 1},
+ {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8
+ | INST_APPEND_SCALAR4),1, 1},
+ {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8
+ | INST_APPEND_ARRAY4), 2, 1},
+ {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1},
+ {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1},
+ {"beginCatch", ASSEM_BEGIN_CATCH,
+ INST_BEGIN_CATCH4, 0, 0},
+ {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1},
+ {"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},
+ {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
+ {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
+ {"dictIncrImm", ASSEM_SINT4_LVT4,
+ INST_DICT_INCR_IMM, 1, 1},
+ {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
+ {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1},
+ {"dictUnset", ASSEM_DICT_UNSET,
+ INST_DICT_UNSET, INT_MIN,1},
+ {"div", ASSEM_1BYTE, INST_DIV, 2, 1},
+ {"dup", ASSEM_1BYTE, INST_DUP, 1, 2},
+ {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0},
+ {"eq", ASSEM_1BYTE, INST_EQ, 2, 1},
+ {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1},
+ {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1},
+ {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1},
+ {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1},
+ {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1},
+ {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1},
+ {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1},
+ {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1},
+ {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1},
+ {"ge", ASSEM_1BYTE, INST_GE, 2, 1},
+ {"gt", ASSEM_1BYTE, INST_GT, 2, 1},
+ {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1},
+ {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1},
+ {"incrArrayImm", ASSEM_LVT1_SINT1,
+ INST_INCR_ARRAY1_IMM, 1, 1},
+ {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1},
+ {"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},
+ {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
+ | INST_INVOKE_STK4), INT_MIN,1},
+ {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
+ {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
+ {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
+ {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
+ {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
+ {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0},
+ {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0},
+ {"label", ASSEM_LABEL, 0, 0, 0},
+ {"land", ASSEM_1BYTE, INST_LAND, 2, 1},
+ {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8
+ | INST_LAPPEND_SCALAR4),
+ 1, 1},
+ {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
+ | INST_LAPPEND_ARRAY4),2, 1},
+ {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
+ {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1},
+ {"le", ASSEM_1BYTE, INST_LE, 2, 1},
+ {"lindexMulti", ASSEM_LINDEX_MULTI,
+ INST_LIST_INDEX_MULTI, INT_MIN,1},
+ {"list", ASSEM_LIST, INST_LIST, INT_MIN,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},
+ {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1},
+ {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1},
+ {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8
+ | INST_LOAD_SCALAR4), 0, 1},
+ {"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},
+ {"lor", ASSEM_1BYTE, INST_LOR, 2, 1},
+ {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
+ {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
+ {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1},
+ {"lt", ASSEM_1BYTE, INST_LT, 2, 1},
+ {"mod", ASSEM_1BYTE, INST_MOD, 2, 1},
+ {"mult", ASSEM_1BYTE, INST_MULT, 2, 1},
+ {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1},
+ {"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
+ {"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
+ {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 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},
+ {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS,
+ 0, 1},
+ {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1},
+ {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1},
+ {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0},
+ {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1},
+ {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8
+ | INST_STORE_SCALAR4), 1, 1},
+ {"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},
+ {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
+ {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
+ {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
+ {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
+ {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
+ {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
+ {"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
+ {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
+ {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
+ {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
+ {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0},
+ {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
+ {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
+ {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
+ {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
+ {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
+ {NULL, 0, 0, 0, 0}
+};
+
+/*
+ * List of instructions that cannot throw an exception under any
+ * circumstances. These instructions are the ones that are permissible after
+ * an exception is caught but before the corresponding exception range is
+ * popped from the stack.
+ * The instructions must be in ascending order by numeric operation code.
+ */
+
+static 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_OVER, /* 95 */
+ INST_PUSH_RETURN_OPTIONS, /* 108 */
+ INST_REVERSE, /* 126 */
+ INST_NOP /* 132 */
+};
+
+/*
+ * Helper macros.
+ */
+
+#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2
+#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr)
+#elif defined(__GNUC__) && __GNUC__ > 2
+#define DEBUG_PRINT(...) /* nothing */
+#else
+#define DEBUG_PRINT /* nothing */
+#endif
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBAdjustStackDepth --
+ *
+ * When an opcode is emitted, adjusts the stack information in the basic
+ * block to reflect the number of operands produced and consumed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates minimum, maximum and final stack requirements in the basic
+ * block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBAdjustStackDepth(
+ BasicBlock *bbPtr, /* Structure describing the basic block */
+ int consumed, /* Count of operands consumed by the
+ * operation */
+ int produced) /* Count of operands produced by the
+ * operation */
+{
+ int depth = bbPtr->finalStackDepth;
+
+ depth -= consumed;
+ if (depth < bbPtr->minStackDepth) {
+ bbPtr->minStackDepth = depth;
+ }
+ depth += produced;
+ if (depth > bbPtr->maxStackDepth) {
+ bbPtr->maxStackDepth = depth;
+ }
+ bbPtr->finalStackDepth = depth;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBUpdateStackReqs --
+ *
+ * Updates the stack requirements of a basic block, given the opcode
+ * being emitted and an operand count.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates min, max and final stack requirements in the basic block.
+ *
+ * Notes:
+ * This function must not be called for instructions such as REVERSE and
+ * OVER that are variadic but do not consume all their operands. Instead,
+ * BBAdjustStackDepth should be called directly.
+ *
+ * count should be provided only for variadic operations. For operations
+ * with known arity, count should be 0.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBUpdateStackReqs(
+ BasicBlock* bbPtr, /* Structure describing the basic block */
+ int tblIdx, /* Index in TalInstructionTable of the
+ * operation being assembled */
+ int count) /* Count of operands for variadic insts */
+{
+ int consumed = TalInstructionTable[tblIdx].operandsConsumed;
+ int produced = TalInstructionTable[tblIdx].operandsProduced;
+
+ if (consumed == INT_MIN) {
+ /*
+ * The instruction is variadic; it consumes 'count' operands.
+ */
+
+ consumed = count;
+ }
+ if (produced < 0) {
+ /*
+ * The instruction leaves some of its variadic operands on the stack,
+ * with net stack effect of '-1-produced'
+ */
+
+ produced = consumed - produced - 1;
+ }
+ BBAdjustStackDepth(bbPtr, consumed, produced);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 --
+ *
+ * Emit the opcode part of an instruction, or the entirety of an
+ * instruction with a 1- or 4-byte operand, and adjust stack
+ * requirements.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Stores instruction and operand in the operand stream, and adjusts the
+ * stack.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBEmitOpcode(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int tblIdx, /* Table index in TalInstructionTable of op */
+ int count) /* Operand count for variadic ops */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ int op = TalInstructionTable[tblIdx].tclInstCode & 0xff;
+
+ /*
+ * If this is the first instruction in a basic block, record its line
+ * number.
+ */
+
+ if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
+ bbPtr->startLine = assemEnvPtr->cmdLine;
+ }
+
+ TclEmitInt1(op, envPtr);
+ envPtr->atCmdStart = ((op) == INST_START_CMD);
+ BBUpdateStackReqs(bbPtr, tblIdx, count);
+}
+
+static void
+BBEmitInstInt1(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int tblIdx, /* Index in TalInstructionTable of op */
+ int opnd, /* 1-byte operand */
+ int count) /* Operand count for variadic ops */
+{
+ BBEmitOpcode(assemEnvPtr, tblIdx, count);
+ TclEmitInt1(opnd, assemEnvPtr->envPtr);
+}
+
+static void
+BBEmitInstInt4(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int tblIdx, /* Index in TalInstructionTable of op */
+ int opnd, /* 4-byte operand */
+ int count) /* Operand count for variadic ops */
+{
+ BBEmitOpcode(assemEnvPtr, tblIdx, count);
+ TclEmitInt4(opnd, assemEnvPtr->envPtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBEmitInst1or4 --
+ *
+ * Emits a 1- or 4-byte operation according to the magnitude of the
+ * operand
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBEmitInst1or4(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int tblIdx, /* Index in TalInstructionTable of op */
+ int param, /* Variable-length parameter */
+ int count) /* Arity if variadic */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ int op = TalInstructionTable[tblIdx].tclInstCode;
+
+ if (param <= 0xff) {
+ op >>= 8;
+ } else {
+ op &= 0xff;
+ }
+ TclEmitInt1(op, envPtr);
+ if (param <= 0xff) {
+ TclEmitInt1(param, envPtr);
+ } else {
+ TclEmitInt4(param, envPtr);
+ }
+ envPtr->atCmdStart = ((op) == INST_START_CMD);
+ BBUpdateStackReqs(bbPtr, tblIdx, count);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_AssembleObjCmd, TclNRAssembleObjCmd --
+ *
+ * Direct evaluation path for tcl::unsupported::assemble
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Assembles the code in objv[1], and executes it, so side effects
+ * include whatever the code does.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+Tcl_AssembleObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ /*
+ * Boilerplate - make sure that there is an NRE trampoline on the C stack
+ * because there needs to be one in place to execute bytecode.
+ */
+
+ return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRAssembleObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ ByteCode *codePtr; /* Pointer to the bytecode to execute */
+ Tcl_Obj* backtrace; /* Object where extra error information is
+ * constructed. */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Assemble the source to bytecode.
+ */
+
+ codePtr = CompileAssembleObj(interp, objv[1]);
+
+ /*
+ * On failure, report error line.
+ */
+
+ if (codePtr == NULL) {
+ Tcl_AddErrorInfo(interp, "\n (\"");
+ Tcl_AddErrorInfo(interp, Tcl_GetString(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_AddErrorInfo(interp, ")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Use NRE to evaluate the bytecode from the trampoline.
+ */
+
+#if 0
+ Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
+ NULL, NULL);
+ return TCL_OK;
+#endif
+ return TclNRExecuteByteCode(interp, codePtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CompileAssembleObj --
+ *
+ * Sets up and assembles Tcl bytecode for the direct-execution path in
+ * the Tcl bytecode assembler.
+ *
+ * Results:
+ * Returns a pointer to the assembled code. Returns NULL if the assembly
+ * fails for any reason, with an appropriate error message in the
+ * interpreter.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static ByteCode *
+CompileAssembleObj(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_Obj *objPtr) /* Source code to assemble */
+{
+ Interp *iPtr = (Interp *) interp;
+ /* Internals of the interpreter */
+ CompileEnv compEnv; /* Compilation environment structure */
+ register ByteCode *codePtr = NULL;
+ /* Bytecode resulting from the assembly */
+ 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 */
+
+ /*
+ * Get the expression ByteCode from the object. If it exists, make sure it
+ * is valid in the current context.
+ */
+
+ if (objPtr->typePtr == &assembleCodeType) {
+ namespacePtr = iPtr->varFramePtr->nsPtr;
+ codePtr = objPtr->internalRep.otherValuePtr;
+ if (((Interp *) *codePtr->interpHandle != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)
+ || (codePtr->nsPtr != namespacePtr)
+ || (codePtr->nsEpoch != namespacePtr->resolverEpoch)
+ || (codePtr->localCachePtr
+ != iPtr->varFramePtr->localCachePtr)) {
+ FreeAssembleCodeInternalRep(objPtr);
+ } else {
+ return codePtr;
+ }
+ }
+
+ /*
+ * Set up the compilation environment, and assemble the code.
+ */
+
+ source = TclGetStringFromObj(objPtr, &sourceLen);
+ TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
+ status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
+ if (status != TCL_OK) {
+ /*
+ * Assembly failed. Clean up and report the error.
+ */
+
+ TclFreeCompileEnv(&compEnv);
+ return NULL;
+ }
+
+ /*
+ * Add a "done" instruction as the last instruction and change the object
+ * into a ByteCode object. Ownership of the literal objects and aux data
+ * items is given to the ByteCode object.
+ */
+
+ TclEmitOpcode(INST_DONE, &compEnv);
+ TclInitByteCodeObj(objPtr, &compEnv);
+ objPtr->typePtr = &assembleCodeType;
+ TclFreeCompileEnv(&compEnv);
+
+ /*
+ * Record the local variable context to which the bytecode pertains
+ */
+
+ codePtr = objPtr->internalRep.otherValuePtr;
+ if (iPtr->varFramePtr->localCachePtr) {
+ codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+ codePtr->localCachePtr->refCount++;
+ }
+
+ /*
+ * Report on what the assembler did.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile >= 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ fflush(stdout);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+
+ return codePtr;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclCompileAssembleCmd --
+ *
+ * Compilation procedure for the '::tcl::unsupported::assemble' command.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Puts the result of assembling the code into the bytecode stream in
+ * 'compileEnv'.
+ *
+ * This procedure makes sure that the command has a single arg, which is
+ * constant. If that condition is met, the procedure calls TclAssembleCode to
+ * produce bytecode for the given assembly code, and returns any error
+ * resulting from the assembly.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+TclCompileAssembleCmd(
+ 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; /* Token in the input script */
+
+ /*
+ * Make sure that the command has a single arg that is a simple word.
+ */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile the code and return any error from the compilation.
+ */
+
+ return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclAssembleCode --
+ *
+ * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl
+ * bytecodes
+ *
+ * Results:
+ * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes
+ * TCL_EVAL_DIRECT, places an error message in the interpreter result.
+ *
+ * Side effects:
+ * Adds byte codes to the compile environment, and updates the
+ * environment's stack depth.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+TclAssembleCode(
+ CompileEnv *envPtr, /* Compilation environment that is to receive
+ * the generated bytecode */
+ const char* codePtr, /* Assembly-language code to be processed */
+ int codeLen, /* Length of the code */
+ int flags) /* OR'ed combination of flags */
+{
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ /*
+ * Walk through the assembly script using the Tcl parser. Each 'command'
+ * will be an instruction or assembly directive.
+ */
+
+ 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 */
+ int status; /* Tcl status return */
+ AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags);
+ Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
+
+ do {
+ /*
+ * Parse out one command line from the assembly script.
+ */
+
+ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
+ instLen = parsePtr->commandSize;
+ if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
+ --instLen;
+ }
+
+ /*
+ * Report errors in the parse.
+ */
+
+ if (status != TCL_OK) {
+ if (flags & TCL_EVAL_DIRECT) {
+ Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
+ instLen);
+ }
+ FreeAssemblyEnv(assemEnvPtr);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance the pointers around any leading commentary.
+ */
+
+ TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr,
+ parsePtr->commandStart);
+ TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
+ parsePtr->commandStart - envPtr->source);
+
+ /*
+ * Process the line of code.
+ */
+
+ if (parsePtr->numWords > 0) {
+ /*
+ * If tracing, show each line assembled as it happens.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
+ printf(" %4d Assembling: ",
+ envPtr->codeNext - envPtr->codeStart);
+ TclPrintSource(stdout, parsePtr->commandStart,
+ TclMin(instLen, 55));
+ printf("\n");
+ }
+#endif
+ if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
+ if (flags & TCL_EVAL_DIRECT) {
+ Tcl_LogCommandInfo(interp, codePtr,
+ parsePtr->commandStart, instLen);
+ }
+ Tcl_FreeParse(parsePtr);
+ FreeAssemblyEnv(assemEnvPtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Advance to the next line of code.
+ */
+
+ nextPtr = parsePtr->commandStart + parsePtr->commandSize;
+ bytesLeft -= (nextPtr - instPtr);
+ instPtr = nextPtr;
+ TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart,
+ instPtr);
+ TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
+ instPtr - envPtr->source);
+ Tcl_FreeParse(parsePtr);
+ } while (bytesLeft > 0);
+
+ /*
+ * Done with parsing the code.
+ */
+
+ status = FinishAssembly(assemEnvPtr);
+ FreeAssemblyEnv(assemEnvPtr);
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * NewAssemblyEnv --
+ *
+ * Creates an environment for the assembler to run in.
+ *
+ * Results:
+ * Allocates, initialises and returns an assembler environment
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static AssemblyEnv*
+NewAssemblyEnv(
+ CompileEnv* envPtr, /* Compilation environment being used for code
+ * generation*/
+ int flags) /* Compilation flags (TCL_EVAL_DIRECT) */
+{
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv));
+ /* Assembler environment under construction */
+ Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ /* Parse of one line of assembly code */
+
+ assemEnvPtr->envPtr = envPtr;
+ assemEnvPtr->parsePtr = parsePtr;
+ assemEnvPtr->cmdLine = envPtr->line;
+ assemEnvPtr->clNext = envPtr->clNext;
+
+ /*
+ * Make the hashtables that store symbol resolution.
+ */
+
+ Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS);
+
+ /*
+ * Start the first basic block.
+ */
+
+ assemEnvPtr->curr_bb = NULL;
+ assemEnvPtr->head_bb = AllocBB(assemEnvPtr);
+ assemEnvPtr->curr_bb = assemEnvPtr->head_bb;
+ assemEnvPtr->head_bb->startLine = 1;
+
+ /*
+ * Stash compilation flags.
+ */
+
+ assemEnvPtr->flags = flags;
+ return assemEnvPtr;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FreeAssemblyEnv --
+ *
+ * Cleans up the assembler environment when assembly is complete.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+FreeAssemblyEnv(
+ AssemblyEnv* assemEnvPtr) /* Environment to free */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment being used for code
+ * generation */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ BasicBlock* thisBB; /* Pointer to a basic block being deleted */
+ BasicBlock* nextBB; /* Pointer to a deleted basic block's
+ * successor */
+
+ /*
+ * Free all the basic block structures.
+ */
+
+ for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
+ if (thisBB->jumpTarget != NULL) {
+ Tcl_DecrRefCount(thisBB->jumpTarget);
+ }
+ if (thisBB->foreignExceptions != NULL) {
+ ckfree(thisBB->foreignExceptions);
+ }
+ nextBB = thisBB->successor1;
+ if (thisBB->jtPtr != NULL) {
+ DeleteMirrorJumpTable(thisBB->jtPtr);
+ thisBB->jtPtr = NULL;
+ }
+ ckfree(thisBB);
+ }
+
+ /*
+ * Free the label hash.
+ */
+
+ while (1) {
+ Tcl_HashEntry* hashEntry;
+ Tcl_HashSearch hashSearch;
+
+ hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash, &hashSearch);
+ if (hashEntry == NULL) {
+ break;
+ }
+ Tcl_DeleteHashEntry(hashEntry);
+ }
+
+ /*
+ * Dispose what's left.
+ */
+
+ TclStackFree(interp, assemEnvPtr->parsePtr);
+ TclStackFree(interp, assemEnvPtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * AssembleOneLine --
+ *
+ * Assembles a single command from an assembly language source.
+ *
+ * Results:
+ * Returns TCL_ERROR with an appropriate error message if the assembly
+ * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly
+ * environment with the state of the assembly.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+AssembleOneLine(
+ AssemblyEnv* assemEnvPtr) /* State of the assembly */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment being used for code
+ * gen */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
+ /* Parse of the line of code */
+ Tcl_Token* tokenPtr; /* Current token within the line of code */
+ Tcl_Obj* instNameObj = NULL;
+ /* Name of the instruction */
+ int tblIdx; /* Index in TalInstructionTable of the
+ * instruction */
+ enum TalInstType instType; /* Type of the instruction */
+ Tcl_Obj* operand1Obj = NULL;
+ /* First operand to the instruction */
+ const char* operand1; /* String rep of the operand */
+ int operand1Len; /* String length of the operand */
+ int opnd; /* Integer representation of an operand */
+ int litIndex; /* Literal pool index of a constant */
+ int localVar; /* LVT index of a local variable */
+ int flags; /* Flags for a basic block */
+ JumptableInfo* jtPtr; /* Pointer to a jumptable */
+ int infoIndex; /* Index of the jumptable in auxdata */
+ int status = TCL_ERROR; /* Return value from this function */
+
+ /*
+ * Make sure that the instruction name is known at compile time.
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ instNameObj = Tcl_NewObj();
+ Tcl_IncrRefCount(instNameObj);
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the instruction name.
+ */
+
+ if (Tcl_GetIndexFromObjStruct(interp, instNameObj,
+ &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction",
+ TCL_EXACT, &tblIdx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Vector on the type of instruction being processed.
+ */
+
+ instType = TalInstructionTable[tblIdx].instType;
+ switch (instType) {
+
+ case ASSEM_PUSH:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
+ goto cleanup;
+ }
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+ operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
+ break;
+
+ case ASSEM_1BYTE:
+ if (parsePtr->numWords != 1) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
+ goto cleanup;
+ }
+ BBEmitOpcode(assemEnvPtr, tblIdx, 0);
+ break;
+
+ case ASSEM_BEGIN_CATCH:
+ /*
+ * Emit the BEGIN_CATCH instruction with the code offset of the
+ * exception branch target instead of the exception range index. The
+ * correct index will be generated and inserted later, when catches
+ * are being resolved.
+ */
+
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
+ goto cleanup;
+ }
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+ assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
+ assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
+ BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0);
+ assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH;
+ StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj);
+ break;
+
+ case ASSEM_BOOL:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
+ goto cleanup;
+ }
+ if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
+ break;
+
+ case ASSEM_BOOL_LVT4:
+ if (parsePtr->numWords != 3) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
+ goto cleanup;
+ }
+ if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
+ TclEmitInt4(localVar, envPtr);
+ break;
+
+ case ASSEM_CONCAT1:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckOneByte(interp, opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_DICT_GET:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
+ break;
+
+ case ASSEM_DICT_SET:
+ if (parsePtr->numWords != 3) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK
+ || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
+ TclEmitInt4(localVar, envPtr);
+ break;
+
+ case ASSEM_DICT_UNSET:
+ if (parsePtr->numWords != 3) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK
+ || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ TclEmitInt4(localVar, envPtr);
+ break;
+
+ case ASSEM_END_CATCH:
+ if (parsePtr->numWords != 1) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
+ goto cleanup;
+ }
+ assemEnvPtr->curr_bb->flags |= BB_ENDCATCH;
+ BBEmitOpcode(assemEnvPtr, tblIdx, 0);
+ StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
+ break;
+
+ case ASSEM_EVAL:
+ /* TODO - Refactor this stuff into a subroutine that takes the inst
+ * code, the message ("script" or "expression") and an evaluator
+ * callback that calls TclCompileScript or TclCompileExpr. */
+
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj,
+ ((TalInstructionTable[tblIdx].tclInstCode
+ == INST_EVAL_STK) ? "script" : "expression"));
+ goto cleanup;
+ }
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
+ TalInstructionTable+tblIdx);
+ } else if (GetNextOperand(assemEnvPtr, &tokenPtr,
+ &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ } else {
+ operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+
+ /*
+ * Assumes that PUSH is the first slot!
+ */
+
+ BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
+ BBEmitOpcode(assemEnvPtr, tblIdx, 0);
+ }
+ break;
+
+ case ASSEM_INVOKE:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+
+ BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_JUMP:
+ case ASSEM_JUMP4:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
+ goto cleanup;
+ }
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+ assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
+ if (instType == ASSEM_JUMP) {
+ flags = BB_JUMP1;
+ BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0);
+ } else {
+ flags = 0;
+ BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0);
+ }
+
+ /*
+ * Start a new basic block at the instruction following the jump.
+ */
+
+ assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
+ if (TalInstructionTable[tblIdx].operandsConsumed != 0) {
+ flags |= BB_FALLTHRU;
+ }
+ StartBasicBlock(assemEnvPtr, flags, operand1Obj);
+ break;
+
+ case ASSEM_JUMPTABLE:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
+ goto cleanup;
+ }
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+
+ jtPtr = ckalloc(sizeof(JumptableInfo));
+
+ Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
+ assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
+ assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
+ DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n",
+ assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
+ envPtr->codeNext - envPtr->codeStart);
+
+ infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
+ DEBUG_PRINT("auxdata index=%d\n", infoIndex);
+
+ BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0);
+ if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+ StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL);
+ break;
+
+ case ASSEM_LABEL:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "name");
+ goto cleanup;
+ }
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
+ goto cleanup;
+ }
+
+ /*
+ * Add the (label_name, address) pair to the hash table.
+ */
+
+ if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ goto cleanup;
+ }
+ break;
+
+ case ASSEM_LINDEX_MULTI:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_LIST:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckNonNegative(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_INDEX:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_LSET_FLAT:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ if (opnd < 2) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("operand must be >=2", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
+ }
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_LVT:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
+ goto cleanup;
+ }
+ if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+ goto cleanup;
+ }
+ BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
+ break;
+
+ case ASSEM_LVT1:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
+ goto cleanup;
+ }
+ if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
+ || CheckOneByte(interp, localVar)) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
+ break;
+
+ case ASSEM_LVT1_SINT1:
+ if (parsePtr->numWords != 3) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
+ goto cleanup;
+ }
+ if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
+ || CheckOneByte(interp, localVar)
+ || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckSignedOneByte(interp, opnd)) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
+ TclEmitInt1(opnd, envPtr);
+ break;
+
+ case ASSEM_LVT4:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
+ goto cleanup;
+ }
+ if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
+ break;
+
+ case ASSEM_OVER:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckNonNegative(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
+ break;
+
+ case ASSEM_REGEXP:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
+ goto cleanup;
+ }
+ if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ {
+ int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0);
+
+ BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0);
+ }
+ break;
+
+ case ASSEM_REVERSE:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckNonNegative(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
+ case ASSEM_SINT1:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckSignedOneByte(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
+ break;
+
+ case ASSEM_SINT4_LVT4:
+ if (parsePtr->numWords != 3) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
+ TclEmitInt4(localVar, envPtr);
+ break;
+
+ default:
+ Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
+ Tcl_GetString(instNameObj));
+ }
+
+ status = TCL_OK;
+ cleanup:
+ if (instNameObj) {
+ Tcl_DecrRefCount(instNameObj);
+ }
+ if (operand1Obj) {
+ Tcl_DecrRefCount(operand1Obj);
+ }
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CompileEmbeddedScript --
+ *
+ * Compile an embedded 'eval' or 'expr' that appears in assembly code.
+ *
+ * This procedure is called when the 'eval' or 'expr' assembly directive is
+ * encountered, and the argument to the directive is a simple word that
+ * requires no substitution. The appropriate compiler (TclCompileScript or
+ * TclCompileExpr) is invoked recursively, and emits bytecode.
+ *
+ * Before the compiler is invoked, the compilation environment's stack
+ * consumption is reset to zero. Upon return from the compilation, the net
+ * stack effect of the compilation is in the compiler env, and this stack
+ * effect is posted to the assembler environment. The compile environment's
+ * stack consumption is then restored to what it was before (which is actually
+ * the state of the stack on entry to the block of assembly code).
+ *
+ * Any exception ranges pushed by the compilation are copied to the basic
+ * block and removed from the compiler environment. They will be rebuilt at
+ * the end of assembly, when the exception stack depth is actually known.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+CompileEmbeddedScript(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token* tokenPtr, /* Tcl_Token containing the script */
+ TalInstDesc* instPtr) /* Instruction that determines whether
+ * the script is 'expr' or 'eval' */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+
+ /*
+ * The expression or script is not only known at compile time, but
+ * actually a "simple word". It can be compiled inline by invoking the
+ * compiler recursively.
+ *
+ * Save away the stack depth and reset it before compiling the script.
+ * We'll record the stack usage of the script in the BasicBlock, and
+ * accumulate it together with the stack usage of the enclosing assembly
+ * code.
+ */
+
+ int savedStackDepth = envPtr->currStackDepth;
+ int savedMaxStackDepth = envPtr->maxStackDepth;
+ int savedCodeIndex = envPtr->codeNext - envPtr->codeStart;
+ int savedExceptArrayNext = envPtr->exceptArrayNext;
+
+ envPtr->currStackDepth = 0;
+ envPtr->maxStackDepth = 0;
+
+ StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
+ switch(instPtr->tclInstCode) {
+ case INST_EVAL_STK:
+ TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
+ break;
+ case INST_EXPR_STK:
+ TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1);
+ break;
+ default:
+ Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen",
+ instPtr->name, instPtr->tclInstCode);
+ }
+
+ /*
+ * Roll up the stack usage of the embedded block into the assembler
+ * environment.
+ */
+
+ SyncStackDepth(assemEnvPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->maxStackDepth = savedMaxStackDepth;
+
+ /*
+ * Save any exception ranges that were pushed by the compiler; they will
+ * need to be fixed up once the stack depth is known.
+ */
+
+ MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex,
+ savedExceptArrayNext);
+
+ /*
+ * Flush the current basic block.
+ */
+
+ StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * SyncStackDepth --
+ *
+ * Copies the stack depth from the compile environment to a basic block.
+ *
+ * Side effects:
+ * Current and max stack depth in the current basic block are adjusted.
+ *
+ * This procedure is called on return from invoking the compiler for the
+ * 'eval' and 'expr' operations. It adjusts the stack depth of the current
+ * basic block to reflect the stack required by the just-compiled code.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+SyncStackDepth(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* curr_bb = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth;
+ /* Max stack depth in the basic block */
+
+ if (maxStackDepth > curr_bb->maxStackDepth) {
+ curr_bb->maxStackDepth = maxStackDepth;
+ }
+ curr_bb->finalStackDepth += envPtr->currStackDepth;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * MoveExceptionRangesToBasicBlock --
+ *
+ * Removes exception ranges that were created by compiling an embedded
+ * script from the CompileEnv, and stores them in the BasicBlock. They
+ * will be reinstalled, at the correct stack depth, after control flow
+ * analysis is complete on the assembly code.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+MoveExceptionRangesToBasicBlock(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int savedCodeIndex, /* Start of the embedded code */
+ int savedExceptArrayNext) /* Saved index of the end of the exception
+ * range array */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* curr_bb = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext;
+ /* Number of ranges that must be moved */
+ int i;
+
+ if (exceptionCount == 0) {
+ /* Nothing to do */
+ return;
+ }
+
+ /*
+ * Save the exception ranges in the basic block. They will be re-added at
+ * the conclusion of assembly; at this time, the INST_BEGIN_CATCH
+ * instructions in the block will be adjusted from whatever range indices
+ * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the
+ * indices that the exceptions acquire. The saved exception ranges are
+ * converted to a relative nesting depth. The depth will be recomputed
+ * once flow analysis has determined the actual stack depth of the block.
+ */
+
+ DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
+ curr_bb, exceptionCount, savedExceptArrayNext);
+ curr_bb->foreignExceptionBase = savedExceptArrayNext;
+ curr_bb->foreignExceptionCount = exceptionCount;
+ curr_bb->foreignExceptions =
+ ckalloc(exceptionCount * sizeof(ExceptionRange));
+ memcpy(curr_bb->foreignExceptions,
+ envPtr->exceptArrayPtr + savedExceptArrayNext,
+ exceptionCount * sizeof(ExceptionRange));
+ for (i = 0; i < exceptionCount; ++i) {
+ curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
+ }
+ envPtr->exceptArrayNext = savedExceptArrayNext;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CreateMirrorJumpTable --
+ *
+ * Makes a jump table with comparison values and assembly code labels.
+ *
+ * Results:
+ * Returns a standard Tcl status, with an error message in the
+ * interpreter on error.
+ *
+ * Side effects:
+ * Initializes the jump table pointer in the current basic block to a
+ * JumptableInfo. The keys in the JumptableInfo are the comparison
+ * strings. The values, instead of being jump displacements, are
+ * Tcl_Obj's with the code labels.
+ */
+
+static int
+CreateMirrorJumpTable(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Obj* jumps) /* List of alternating keywords and labels */
+{
+ int objc; /* Number of elements in the 'jumps' list */
+ Tcl_Obj** objv; /* Pointers to the elements in the list */
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ BasicBlock* bbPtr = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ JumptableInfo* jtPtr;
+ Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */
+ Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */
+ int isNew; /* Flag==1 if the key is not yet in the
+ * table. */
+ Tcl_Obj* result; /* Error message */
+ int i;
+
+ if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc % 2 != 0) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "jump table must have an even number of list elements",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate the jumptable.
+ */
+
+ jtPtr = ckalloc(sizeof(JumptableInfo));
+ jtHashPtr = &jtPtr->hashTable;
+ Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
+
+ /*
+ * Fill the keys and labels into the table.
+ */
+
+ DEBUG_PRINT("jump table {\n");
+ for (i = 0; i < objc; i+=2) {
+ DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
+ Tcl_GetString(objv[i+1]));
+ hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
+ &isNew);
+ if (!isNew) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ result = Tcl_NewStringObj(
+ "duplicate entry in jump table for \"", -1);
+ Tcl_AppendObjToObj(result, objv[i]);
+ Tcl_AppendToObj(result, "\"", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
+ DeleteMirrorJumpTable(jtPtr);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]);
+ Tcl_IncrRefCount(objv[i+1]);
+ }
+ DEBUG_PRINT("}\n");
+
+ /*
+ * Put the mirror jumptable in the basic block struct.
+ */
+
+ bbPtr->jtPtr = jtPtr;
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * DeleteMirrorJumpTable --
+ *
+ * Cleans up a jump table when the basic block is deleted.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+DeleteMirrorJumpTable(
+ JumptableInfo* jtPtr)
+{
+ Tcl_HashTable* jtHashPtr = &jtPtr->hashTable;
+ /* Hash table pointer */
+ Tcl_HashSearch search; /* Hash search control */
+ Tcl_HashEntry* entry; /* Hash table entry containing a jump label */
+ Tcl_Obj* label; /* Jump label from the hash table */
+
+ for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
+ entry != NULL;
+ entry = Tcl_NextHashEntry(&search)) {
+ label = Tcl_GetHashValue(entry);
+ Tcl_DecrRefCount(label);
+ Tcl_SetHashValue(entry, NULL);
+ }
+ Tcl_DeleteHashTable(jtHashPtr);
+ ckfree(jtPtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * GetNextOperand --
+ *
+ * Retrieves the next operand in sequence from an assembly instruction,
+ * and makes sure that its value is known at compile time.
+ *
+ * Results:
+ * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand
+ * text in *operandObjPtr. In case of failure, returns TCL_ERROR and
+ * leaves *operandObjPtr untouched.
+ *
+ * Side effects:
+ * Advances *tokenPtrPtr around the token just processed.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+GetNextOperand(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding
+ * the operand */
+ Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text
+ * with \-substitutions done. */
+{
+ Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
+ Tcl_Obj* operandObj = Tcl_NewObj();
+
+ if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
+ Tcl_DecrRefCount(operandObj);
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "assembly code may not contain substitutions", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
+ }
+ return TCL_ERROR;
+ }
+ *tokenPtrPtr = TokenAfter(*tokenPtrPtr);
+ Tcl_IncrRefCount(operandObj);
+ *operandObjPtr = operandObj;
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * GetBooleanOperand --
+ *
+ * Retrieves a Boolean operand from the input stream and advances
+ * the token pointer.
+ *
+ * Results:
+ * Returns a standard Tcl result (with an error message in the
+ * interpreter on failure).
+ *
+ * Side effects:
+ * Stores the Boolean value in (*result) and advances (*tokenPtrPtr)
+ * to the next token.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+GetBooleanOperand(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token** tokenPtrPtr, /* Current token from the parser */
+ int* result) /* OUTPUT: Integer extracted from the token */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Token* tokenPtr = *tokenPtrPtr;
+ /* INOUT: Pointer to the next token in the
+ * source code */
+ Tcl_Obj* intObj = Tcl_NewObj();
+ /* Integer from the source code */
+ int status; /* Tcl status return */
+
+ /*
+ * Extract the next token as a string.
+ */
+
+ Tcl_IncrRefCount(intObj);
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
+ Tcl_DecrRefCount(intObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert to an integer, advance to the next token and return.
+ */
+
+ status = Tcl_GetBooleanFromObj(interp, intObj, result);
+ Tcl_DecrRefCount(intObj);
+ *tokenPtrPtr = TokenAfter(tokenPtr);
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * GetIntegerOperand --
+ *
+ * Retrieves an integer operand from the input stream and advances the
+ * token pointer.
+ *
+ * Results:
+ * Returns a standard Tcl result (with an error message in the
+ * interpreter on failure).
+ *
+ * Side effects:
+ * Stores the integer value in (*result) and advances (*tokenPtrPtr) to
+ * the next token.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+GetIntegerOperand(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token** tokenPtrPtr, /* Current token from the parser */
+ int* result) /* OUTPUT: Integer extracted from the token */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Token* tokenPtr = *tokenPtrPtr;
+ /* INOUT: Pointer to the next token in the
+ * source code */
+ Tcl_Obj* intObj = Tcl_NewObj();
+ /* Integer from the source code */
+ int status; /* Tcl status return */
+
+ /*
+ * Extract the next token as a string.
+ */
+
+ Tcl_IncrRefCount(intObj);
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
+ Tcl_DecrRefCount(intObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert to an integer, advance to the next token and return.
+ */
+
+ status = Tcl_GetIntFromObj(interp, intObj, result);
+ Tcl_DecrRefCount(intObj);
+ *tokenPtrPtr = TokenAfter(tokenPtr);
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * GetListIndexOperand --
+ *
+ * Gets the value of an operand intended to serve as a list index.
+ *
+ * Results:
+ * Returns a standard Tcl result: TCL_OK if the parse is successful and
+ * TCL_ERROR (with an appropriate error message) if the parse fails.
+ *
+ * Side effects:
+ * Stores the list index at '*index'. Values between -1 and 0x7fffffff
+ * have their natural meaning; values between -2 and -0x80000000
+ * represent 'end-2-N'.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+GetListIndexOperand(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token** tokenPtrPtr, /* Current token from the parser */
+ int* result) /* OUTPUT: Integer extracted from the token */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Token* tokenPtr = *tokenPtrPtr;
+ /* INOUT: Pointer to the next token in the
+ * source code */
+ Tcl_Obj* intObj = Tcl_NewObj();
+ /* Integer from the source code */
+ int status; /* Tcl status return */
+
+ /*
+ * Extract the next token as a string.
+ */
+
+ Tcl_IncrRefCount(intObj);
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
+ Tcl_DecrRefCount(intObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert to an integer, advance to the next token and return.
+ */
+
+ status = TclGetIntForIndex(interp, intObj, -2, result);
+ Tcl_DecrRefCount(intObj);
+ *tokenPtrPtr = TokenAfter(tokenPtr);
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FindLocalVar --
+ *
+ * Gets the name of a local variable from the input stream and advances
+ * the token pointer.
+ *
+ * Results:
+ * Returns the LVT index of the local variable. Returns -1 if the
+ * variable is non-local, not known at compile time, or cannot be
+ * installed in the LVT (leaving an error message in the interpreter
+ * result if necessary).
+ *
+ * Side effects:
+ * Advances the token pointer. May define a new LVT slot if the variable
+ * has not yet been seen and the execution context allows for it.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+FindLocalVar(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ Tcl_Token** tokenPtrPtr)
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Token* tokenPtr = *tokenPtrPtr;
+ /* INOUT: Pointer to the next token
+ * in the source code */
+ Tcl_Obj* varNameObj = Tcl_NewObj();
+ /* Name of the variable */
+ const char* varNameStr;
+ int varNameLen;
+ int localVar; /* Index of the variable in the LVT */
+
+ Tcl_IncrRefCount(varNameObj);
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
+ Tcl_DecrRefCount(varNameObj);
+ return -1;
+ }
+ varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
+ if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
+ return -1;
+ }
+ localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
+ Tcl_DecrRefCount(varNameObj);
+ if (localVar == -1) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot use this instruction to create a variable"
+ " in a non-proc context", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+ }
+ return -1;
+ }
+ *tokenPtrPtr = TokenAfter(tokenPtr);
+ return localVar;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckNamespaceQualifiers --
+ *
+ * Verify that a variable name has no namespace qualifiers before
+ * attempting to install it in the LVT.
+ *
+ * Results:
+ * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
+ * an error message in the interpreter result.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckNamespaceQualifiers(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ const char* name, /* Variable name to check */
+ int nameLen) /* Length of the variable */
+{
+ Tcl_Obj* result; /* Error message */
+ const char* p;
+ for (p = name; p+2 < name+nameLen; p++) {
+ if ((*p == ':') && (p[1] == ':')) {
+ result = Tcl_NewStringObj("variable \"", -1);
+ Tcl_AppendToObj(result, name, -1);
+ Tcl_AppendToObj(result, "\" is not local", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckOneByte --
+ *
+ * Verify that a constant fits in a single byte in the instruction
+ * stream.
+ *
+ * Results:
+ * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
+ * an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_SCALAR1
+ * are possible on a given local variable. The fact that there is no
+ * INCR_SCALAR4 is puzzling.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckOneByte(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ int value) /* Value to check */
+{
+ Tcl_Obj* result; /* Error message */
+
+ if (value < 0 || value > 0xff) {
+ result = Tcl_NewStringObj("operand does not fit in one byte", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckSignedOneByte --
+ *
+ * Verify that a constant fits in a single signed byte in the instruction
+ * stream.
+ *
+ * Results:
+ * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
+ * an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_SCALAR1
+ * are possible on a given local variable. The fact that there is no
+ * INCR_SCALAR4 is puzzling.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckSignedOneByte(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ int value) /* Value to check */
+{
+ Tcl_Obj* result; /* Error message */
+
+ if (value > 0x7f || value < -0x80) {
+ result = Tcl_NewStringObj("operand does not fit in one byte", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckNonNegative --
+ *
+ * Verify that a constant is nonnegative
+ *
+ * Results:
+ * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
+ * an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_INVOKE
+ * are consuming a positive number of operands
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckNonNegative(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ int value) /* Value to check */
+{
+ Tcl_Obj* result; /* Error message */
+
+ if (value < 0) {
+ result = Tcl_NewStringObj("operand must be nonnegative", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckStrictlyPositive --
+ *
+ * Verify that a constant is positive
+ *
+ * Results:
+ * On success, returns TCL_OK. On failure, returns TCL_ERROR and
+ * stores an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_INVOKE
+ * are consuming a positive number of operands
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckStrictlyPositive(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ int value) /* Value to check */
+{
+ Tcl_Obj* result; /* Error message */
+
+ if (value <= 0) {
+ result = Tcl_NewStringObj("operand must be positive", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * DefineLabel --
+ *
+ * Defines a label appearing in the assembly sequence.
+ *
+ * Results:
+ * Returns a standard Tcl result. Returns TCL_OK and an empty result if
+ * the definition succeeds; returns TCL_ERROR and an appropriate message
+ * if a duplicate definition is found.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+DefineLabel(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ const char* labelName) /* Label being defined */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_HashEntry* entry; /* Label's entry in the symbol table */
+ int isNew; /* Flag == 1 iff the label was previously
+ * undefined */
+ Tcl_Obj* result; /* Error message */
+
+ /* TODO - This can now be simplified! */
+
+ StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
+
+ /*
+ * Look up the newly-defined label in the symbol table.
+ */
+
+ entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew);
+ if (!isNew) {
+ /*
+ * This is a duplicate label.
+ */
+
+ if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) {
+ result = Tcl_NewStringObj(
+ "duplicate definition of label \"", -1);
+ Tcl_AppendToObj(result, labelName, -1);
+ Tcl_AppendToObj(result, "\"", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL",
+ labelName, NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * This is the first appearance of the label in the code.
+ */
+
+ Tcl_SetHashValue(entry, assemEnvPtr->curr_bb);
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * StartBasicBlock --
+ *
+ * Starts a new basic block when a label or jump is encountered.
+ *
+ * Results:
+ * Returns a pointer to the BasicBlock structure of the new
+ * basic block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static BasicBlock*
+StartBasicBlock(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int flags, /* Flags to apply to the basic block being
+ * closed, if there is one. */
+ Tcl_Obj* jumpLabel) /* Label of the location that the block jumps
+ * to, or NULL if the block does not jump */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* newBB; /* BasicBlock structure for the new block */
+ BasicBlock* currBB = assemEnvPtr->curr_bb;
+
+ /*
+ * Coalesce zero-length blocks.
+ */
+
+ if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) {
+ currBB->startLine = assemEnvPtr->cmdLine;
+ return currBB;
+ }
+
+ /*
+ * Make the new basic block.
+ */
+
+ newBB = AllocBB(assemEnvPtr);
+
+ /*
+ * Record the jump target if there is one.
+ */
+
+ currBB->jumpTarget = jumpLabel;
+ if (jumpLabel != NULL) {
+ Tcl_IncrRefCount(currBB->jumpTarget);
+ }
+
+ /*
+ * Record the fallthrough if there is one.
+ */
+
+ currBB->flags |= flags;
+
+ /*
+ * Record the successor block.
+ */
+
+ currBB->successor1 = newBB;
+ assemEnvPtr->curr_bb = newBB;
+ return newBB;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * AllocBB --
+ *
+ * Allocates a new basic block
+ *
+ * Results:
+ * Returns a pointer to the newly allocated block, which is initialized
+ * to contain no code and begin at the current instruction pointer.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static BasicBlock *
+AllocBB(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ BasicBlock *bb = ckalloc(sizeof(BasicBlock));
+
+ bb->originalStartOffset =
+ bb->startOffset = envPtr->codeNext - envPtr->codeStart;
+ bb->startLine = assemEnvPtr->cmdLine + 1;
+ bb->jumpOffset = -1;
+ bb->jumpLine = -1;
+ bb->prevPtr = assemEnvPtr->curr_bb;
+ bb->predecessor = NULL;
+ bb->successor1 = NULL;
+ bb->jumpTarget = NULL;
+ bb->initialStackDepth = 0;
+ bb->minStackDepth = 0;
+ bb->maxStackDepth = 0;
+ bb->finalStackDepth = 0;
+ bb->enclosingCatch = NULL;
+ bb->foreignExceptionBase = -1;
+ bb->foreignExceptionCount = 0;
+ bb->foreignExceptions = NULL;
+ bb->jtPtr = NULL;
+ bb->flags = 0;
+
+ return bb;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FinishAssembly --
+ *
+ * Postprocessing after all bytecode has been generated for a block of
+ * assembly code.
+ *
+ * Results:
+ * Returns a standard Tcl result, with an error message left in the
+ * interpreter if appropriate.
+ *
+ * Side effects:
+ * The program is checked to see if any undefined labels remain. The
+ * initial stack depth of all the basic blocks in the flow graph is
+ * calculated and saved. The stack balance on exit is computed, checked
+ * and saved.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+FinishAssembly(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ int mustMove; /* Amount by which the code needs to be grown
+ * because of expanding jumps */
+
+ /*
+ * Resolve the targets of all jumps and determine whether code needs to be
+ * moved around.
+ */
+
+ if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Move the code if necessary.
+ */
+
+ if (mustMove) {
+ MoveCodeForJumps(assemEnvPtr, mustMove);
+ }
+
+ /*
+ * Resolve jump target labels to bytecode offsets.
+ */
+
+ FillInJumpOffsets(assemEnvPtr);
+
+ /*
+ * Label each basic block with its catch context. Quit on inconsistency.
+ */
+
+ if (ProcessCatches(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make sure that no block accessible from a catch's error exit that hasn't
+ * popped the exception stack can throw an exception.
+ */
+
+ if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compute stack balance throughout the program.
+ */
+
+ if (CheckStack(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* TODO - Check for unreachable code */
+ /* Maybe not - unreachable code is Mostly Harmless. */
+
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CalculateJumpRelocations --
+ *
+ * Calculate any movement that has to be done in the assembly code to
+ * expand JUMP1 instructions to JUMP4 (because they jump more than a
+ * 1-byte range).
+ *
+ * Results:
+ * Returns a standard Tcl result, with an appropriate error message if
+ * anything fails.
+ *
+ * Side effects:
+ * Sets the 'startOffset' pointer in every basic block to the new origin
+ * of the block, and turns off JUMP1 flags on instructions that must be
+ * expanded (and adjusts them to the corresponding JUMP4's). Does *not*
+ * store the jump offsets at this point.
+ *
+ * Sets *mustMove to 1 if and only if at least one instruction changed
+ * size so the code must be moved.
+ *
+ * As a side effect, also checks for undefined labels and reports them.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CalculateJumpRelocations(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int* mustMove) /* OUTPUT: Number of bytes that have been
+ * added to the code */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr; /* Pointer to a basic block being checked */
+ Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */
+ BasicBlock* jumpTarget; /* Basic block where the jump goes */
+ int motion; /* Amount by which the code has expanded */
+ int offset; /* Offset in the bytecode from a jump
+ * instruction to its target */
+ unsigned opcode; /* Opcode in the bytecode being adjusted */
+
+ /*
+ * Iterate through basic blocks as long as a change results in code
+ * expansion.
+ */
+
+ *mustMove = 0;
+ do {
+ motion = 0;
+ for (bbPtr = assemEnvPtr->head_bb;
+ bbPtr != NULL;
+ bbPtr=bbPtr->successor1) {
+ /*
+ * Advance the basic block start offset by however many bytes we
+ * have inserted in the code up to this point
+ */
+
+ bbPtr->startOffset += motion;
+
+ /*
+ * If the basic block references a label (and hence performs a
+ * jump), find the location of the label. Report an error if the
+ * label is missing.
+ */
+
+ if (bbPtr->jumpTarget != NULL) {
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(bbPtr->jumpTarget));
+ if (entry == NULL) {
+ ReportUndefinedLabel(assemEnvPtr, bbPtr,
+ bbPtr->jumpTarget);
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the instruction is a JUMP1, turn it into a JUMP4 if its
+ * target is out of range.
+ */
+
+ jumpTarget = Tcl_GetHashValue(entry);
+ if (bbPtr->flags & BB_JUMP1) {
+ offset = jumpTarget->startOffset
+ - (bbPtr->jumpOffset + motion);
+ if (offset < -0x80 || offset > 0x7f) {
+ opcode = TclGetUInt1AtPtr(envPtr->codeStart
+ + bbPtr->jumpOffset);
+ ++opcode;
+ TclStoreInt1AtPtr(opcode,
+ envPtr->codeStart + bbPtr->jumpOffset);
+ motion += 3;
+ bbPtr->flags &= ~BB_JUMP1;
+ }
+ }
+ }
+
+ /*
+ * If the basic block references a jump table, that doesn't affect
+ * the code locations, but resolve the labels now, and store basic
+ * block pointers in the jumptable hash.
+ */
+
+ if (bbPtr->flags & BB_JUMPTABLE) {
+ if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ *mustMove += motion;
+ } while (motion != 0);
+
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckJumpTableLabels --
+ *
+ * Make sure that all the labels in a jump table are defined.
+ *
+ * Results:
+ * Returns TCL_OK if they are, TCL_ERROR if they aren't.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckJumpTableLabels(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr) /* Basic block that ends in a jump table */
+{
+ Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
+ /* Hash table with the symbols */
+ Tcl_HashSearch search; /* Hash table iterator */
+ Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
+ Tcl_Obj* symbolObj; /* Jump target */
+ Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
+
+ /*
+ * Look up every jump target in the jump hash.
+ */
+
+ DEBUG_PRINT("check jump table labels %p {\n", bbPtr);
+ for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
+ symEntryPtr != NULL;
+ symEntryPtr = Tcl_NextHashEntry(&search)) {
+ symbolObj = Tcl_GetHashValue(symEntryPtr);
+ valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(symbolObj));
+ DEBUG_PRINT(" %s -> %s (%d)\n",
+ (char*) Tcl_GetHashKey(symHash, symEntryPtr),
+ Tcl_GetString(symbolObj),
+ (valEntryPtr != NULL));
+ if (valEntryPtr == NULL) {
+ ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
+ return TCL_ERROR;
+ }
+ }
+ DEBUG_PRINT("}\n");
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ReportUndefinedLabel --
+ *
+ * Report that a basic block refers to an undefined jump label
+ *
+ * Side effects:
+ * Stores an error message, error code, and line number information in
+ * the assembler's Tcl interpreter.
+ *
+ *-----------------------------------------------------------------------------
+ */
+static void
+ReportUndefinedLabel(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr, /* Basic block that contains the undefined
+ * label */
+ Tcl_Obj* jumpTarget) /* Label of a jump target */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Obj* result; /* Error message */
+
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ result = Tcl_NewStringObj("undefined label \"", -1);
+ Tcl_AppendObjToObj(result, jumpTarget);
+ Tcl_AppendToObj(result, "\"", -1);
+ Tcl_SetObjResult(interp, result);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
+ Tcl_GetString(jumpTarget), NULL);
+ Tcl_SetErrorLine(interp, bbPtr->jumpLine);
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * MoveCodeForJumps --
+ *
+ * Move bytecodes in memory to accommodate JUMP1 instructions that have
+ * expanded to become JUMP4's.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+MoveCodeForJumps(
+ AssemblyEnv* assemEnvPtr, /* Assembler environment */
+ int mustMove) /* Number of bytes of added code */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr; /* Pointer to a basic block being checked */
+ int topOffset; /* Bytecode offset of the following basic
+ * block before code motion */
+
+ /*
+ * Make sure that there is enough space in the bytecode array to
+ * accommodate the expanded code.
+ */
+
+ while (envPtr->codeEnd < envPtr->codeNext + mustMove) {
+ TclExpandCodeArray(envPtr);
+ }
+
+ /*
+ * Iterate through the bytecodes in reverse order, and move them upward to
+ * their new homes.
+ */
+
+ topOffset = envPtr->codeNext - envPtr->codeStart;
+ for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) {
+ DEBUG_PRINT("move code from %d to %d\n",
+ bbPtr->originalStartOffset, bbPtr->startOffset);
+ memmove(envPtr->codeStart + bbPtr->startOffset,
+ envPtr->codeStart + bbPtr->originalStartOffset,
+ topOffset - bbPtr->originalStartOffset);
+ topOffset = bbPtr->originalStartOffset;
+ bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset);
+ }
+ envPtr->codeNext += mustMove;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FillInJumpOffsets --
+ *
+ * Fill in the final offsets of all jump instructions once bytecode
+ * locations have been completely determined.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+FillInJumpOffsets(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr; /* Pointer to a basic block being checked */
+ Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */
+ BasicBlock* jumpTarget; /* Basic block where a jump goes */
+ int fromOffset; /* Bytecode location of a jump instruction */
+ int targetOffset; /* Bytecode location of a jump instruction's
+ * target */
+
+ for (bbPtr = assemEnvPtr->head_bb;
+ bbPtr != NULL;
+ bbPtr = bbPtr->successor1) {
+ if (bbPtr->jumpTarget != NULL) {
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(bbPtr->jumpTarget));
+ jumpTarget = Tcl_GetHashValue(entry);
+ fromOffset = bbPtr->jumpOffset;
+ targetOffset = jumpTarget->startOffset;
+ if (bbPtr->flags & BB_JUMP1) {
+ TclStoreInt1AtPtr(targetOffset - fromOffset,
+ envPtr->codeStart + fromOffset + 1);
+ } else {
+ TclStoreInt4AtPtr(targetOffset - fromOffset,
+ envPtr->codeStart + fromOffset + 1);
+ }
+ }
+ if (bbPtr->flags & BB_JUMPTABLE) {
+ ResolveJumpTableTargets(assemEnvPtr, bbPtr);
+ }
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ResolveJumpTableTargets --
+ *
+ * Puts bytecode addresses for the targets of a jumptable into the
+ * table
+ *
+ * Results:
+ * Returns TCL_OK if they are, TCL_ERROR if they aren't.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+ResolveJumpTableTargets(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr) /* Basic block that ends in a jump table */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
+ /* Hash table with the symbols */
+ Tcl_HashSearch search; /* Hash table iterator */
+ Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
+ Tcl_Obj* symbolObj; /* Jump target */
+ Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
+ int auxDataIndex; /* Index of the auxdata */
+ JumptableInfo* realJumpTablePtr;
+ /* Jump table in the actual code */
+ Tcl_HashTable* realJumpHashPtr;
+ /* Jump table hash in the actual code */
+ Tcl_HashEntry* realJumpEntryPtr;
+ /* Entry in the jump table hash in
+ * the actual code */
+ BasicBlock* jumpTargetBBPtr;
+ /* Basic block that the jump proceeds to */
+ int junk;
+
+ auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
+ DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
+ bbPtr, bbPtr->jumpOffset, auxDataIndex);
+ realJumpTablePtr = (JumptableInfo*)
+ envPtr->auxDataArrayPtr[auxDataIndex].clientData;
+ realJumpHashPtr = &realJumpTablePtr->hashTable;
+
+ /*
+ * Look up every jump target in the jump hash.
+ */
+
+ DEBUG_PRINT("resolve jump table {\n");
+ for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
+ symEntryPtr != NULL;
+ symEntryPtr = Tcl_NextHashEntry(&search)) {
+ symbolObj = Tcl_GetHashValue(symEntryPtr);
+ DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+
+ valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(symbolObj));
+ jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr);
+
+ realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
+ Tcl_GetHashKey(symHash, symEntryPtr), &junk);
+ DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
+ (char*) Tcl_GetHashKey(symHash, symEntryPtr),
+ Tcl_GetString(symbolObj), jumpTargetBBPtr,
+ jumpTargetBBPtr->startOffset, realJumpEntryPtr);
+
+ Tcl_SetHashValue(realJumpEntryPtr,
+ INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset));
+ }
+ DEBUG_PRINT("}\n");
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckForThrowInWrongContext --
+ *
+ * Verify that no beginCatch/endCatch sequence can throw an exception
+ * after an original exception is caught and before its exception context
+ * is removed from the stack.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Stores an appropriate error message in the interpreter as needed.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckForThrowInWrongContext(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ BasicBlock* blockPtr; /* Current basic block */
+
+ /*
+ * Walk through the basic blocks in turn, checking all the ones that have
+ * caught an exception and not disposed of it properly.
+ */
+
+ for (blockPtr = assemEnvPtr->head_bb;
+ blockPtr != NULL;
+ blockPtr = blockPtr->successor1) {
+ if (blockPtr->catchState == BBCS_CAUGHT) {
+ /*
+ * Walk through the instructions in the basic block.
+ */
+
+ if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckNonThrowingBlock --
+ *
+ * Check that a basic block cannot throw an exception.
+ *
+ * Results:
+ * Returns TCL_ERROR if the block cannot be proven to be nonthrowing.
+ *
+ * Side effects:
+ * Stashes an error message in the interpreter result.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckNonThrowingBlock(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* blockPtr) /* Basic block where exceptions are not
+ * allowed */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ BasicBlock* nextPtr; /* Pointer to the succeeding basic block */
+ int offset; /* Bytecode offset of the current
+ * instruction */
+ int bound; /* Bytecode offset following the last
+ * instruction of the block. */
+ unsigned char opcode; /* Current bytecode instruction */
+ Tcl_Obj* retval; /* Error message */
+
+ /*
+ * Determine where in the code array the basic block ends.
+ */
+
+ nextPtr = blockPtr->successor1;
+ if (nextPtr == NULL) {
+ bound = envPtr->codeNext - envPtr->codeStart;
+ } else {
+ bound = nextPtr->startOffset;
+ }
+
+ /*
+ * Walk through the instructions of the block.
+ */
+
+ offset = blockPtr->startOffset;
+ while (offset < bound) {
+ /*
+ * Determine whether an instruction is nonthrowing.
+ */
+
+ opcode = (envPtr->codeStart)[offset];
+ if (BytecodeMightThrow(opcode)) {
+ /*
+ * Report an error for a throw in the wrong context.
+ */
+
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ retval = Tcl_NewStringObj("\"", -1);
+ Tcl_AppendToObj(retval, tclInstructionTable[opcode].name, -1);
+ Tcl_AppendToObj(retval, "\" instruction may not appear in "
+ "a context where an exception has been "
+ "caught and not disposed of.", -1);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
+ Tcl_SetObjResult(interp, retval);
+ AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
+ }
+ return TCL_ERROR;
+ }
+ offset += tclInstructionTable[opcode].numBytes;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BytecodeMightThrow --
+ *
+ * Tests if a given bytecode instruction might throw an exception.
+ *
+ * Results:
+ * Returns 1 if the bytecode might throw an exception, 0 if the
+ * instruction is known never to throw.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+BytecodeMightThrow(
+ unsigned char opcode)
+{
+ /*
+ * Binary search on the non-throwing bytecode list.
+ */
+
+ int min = 0;
+ int max = sizeof(NonThrowingByteCodes)-1;
+ int mid;
+ unsigned char c;
+
+ while (max >= min) {
+ mid = (min + max) / 2;
+ c = NonThrowingByteCodes[mid];
+ if (opcode < c) {
+ max = mid-1;
+ } else if (opcode > c) {
+ min = mid+1;
+ } else {
+ /*
+ * Opcode is nonthrowing.
+ */
+
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckStack --
+ *
+ * Audit stack usage in a block of assembly code.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Updates stack depth on entry for all basic blocks in the flowgraph.
+ * Calculates the max stack depth used in the program, and updates the
+ * compilation environment to reflect it.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckStack(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ int maxDepth; /* Maximum stack depth overall */
+
+ /*
+ * Checking the head block will check all the other blocks recursively.
+ */
+
+ assemEnvPtr->maxDepth = 0;
+ if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL,
+ 0) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Post the max stack depth back to the compilation environment.
+ */
+
+ maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth;
+ if (maxDepth > envPtr->maxStackDepth) {
+ envPtr->maxStackDepth = maxDepth;
+ }
+
+ /*
+ * If the exit is reachable, make sure that the program exits with 1
+ * operand on the stack.
+ */
+
+ if (StackCheckExit(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Reset the visited state on all basic blocks.
+ */
+
+ ResetVisitedBasicBlocks(assemEnvPtr);
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * StackCheckBasicBlock --
+ *
+ * Checks stack consumption for a basic block (and recursively for its
+ * successors).
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Updates initial stack depth for the basic block and its successors.
+ * (Final and maximum stack depth are relative to initial, and are not
+ * touched).
+ *
+ * This procedure eventually checks, for the entire flow graph, whether stack
+ * balance is consistent. It is an error for a given basic block to be
+ * reachable along multiple flow paths with different stack depths.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+StackCheckBasicBlock(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* blockPtr, /* Pointer to the basic block being checked */
+ BasicBlock* predecessor, /* Pointer to the block that passed control to
+ * this one. */
+ int initialStackDepth) /* Stack depth on entry to the block */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ BasicBlock* jumpTarget; /* Basic block where a jump goes */
+ int stackDepth; /* Current stack depth */
+ int maxDepth; /* Maximum stack depth so far */
+ int result; /* Tcl status return */
+ Tcl_HashSearch jtSearch; /* Search structure for the jump table */
+ Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */
+ Tcl_Obj* targetLabel; /* Target label from the jump table */
+ Tcl_HashEntry* entry; /* Hash entry in the label table */
+
+ if (blockPtr->flags & BB_VISITED) {
+ /*
+ * If the block is already visited, check stack depth for consistency
+ * among the paths that reach it.
+ */
+
+ if (blockPtr->initialStackDepth == initialStackDepth) {
+ return TCL_OK;
+ }
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "inconsistent stack depths on two execution paths", -1));
+ /* TODO - add execution trace of both paths */
+ Tcl_SetErrorLine(interp, blockPtr->startLine);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the block is not already visited, set the 'predecessor' link to
+ * indicate how control got to it. Set the initial stack depth to the
+ * current stack depth in the flow of control.
+ */
+
+ blockPtr->flags |= BB_VISITED;
+ blockPtr->predecessor = predecessor;
+ blockPtr->initialStackDepth = initialStackDepth;
+
+ /*
+ * Calculate minimum stack depth, and flag an error if the block
+ * underflows the stack.
+ */
+
+ if (initialStackDepth + blockPtr->minStackDepth < 0) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
+ Tcl_SetErrorLine(interp, blockPtr->startLine);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make sure that the block doesn't try to pop below the stack level of an
+ * enclosing catch.
+ */
+
+ if (blockPtr->enclosingCatch != 0 &&
+ initialStackDepth + blockPtr->minStackDepth
+ < (blockPtr->enclosingCatch->initialStackDepth
+ + blockPtr->enclosingCatch->finalStackDepth)) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "code pops stack below level of enclosing catch", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1);
+ AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
+ Tcl_SetErrorLine(interp, blockPtr->startLine);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Update maximum stgack depth.
+ */
+
+ maxDepth = initialStackDepth + blockPtr->maxStackDepth;
+ if (maxDepth > assemEnvPtr->maxDepth) {
+ assemEnvPtr->maxDepth = maxDepth;
+ }
+
+ /*
+ * Calculate stack depth on exit from the block, and invoke this procedure
+ * recursively to check successor blocks.
+ */
+
+ stackDepth = initialStackDepth + blockPtr->finalStackDepth;
+ result = TCL_OK;
+ if (blockPtr->flags & BB_FALLTHRU) {
+ result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
+ blockPtr, stackDepth);
+ }
+
+ if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(blockPtr->jumpTarget));
+ jumpTarget = Tcl_GetHashValue(entry);
+ result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
+ stackDepth);
+ }
+
+ /*
+ * All blocks referenced in a jump table are successors.
+ */
+
+ if (blockPtr->flags & BB_JUMPTABLE) {
+ for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable,
+ &jtSearch);
+ result == TCL_OK && jtEntry != NULL;
+ jtEntry = Tcl_NextHashEntry(&jtSearch)) {
+ targetLabel = Tcl_GetHashValue(jtEntry);
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(targetLabel));
+ jumpTarget = Tcl_GetHashValue(entry);
+ result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
+ blockPtr, stackDepth);
+ }
+ }
+
+ return result;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * StackCheckExit --
+ *
+ * Makes sure that the net stack effect of an entire assembly language
+ * script is to push 1 result.
+ *
+ * Results:
+ * Returns a standard Tcl result, with an error message in the
+ * interpreter result if the stack is wrong.
+ *
+ * Side effects:
+ * If the assembly code had a net stack effect of zero, emits code to the
+ * concluding block to push a null result. In any case, updates the stack
+ * depth in the compile environment to reflect the net effect of the
+ * assembly code.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+StackCheckExit(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ int depth; /* Net stack effect */
+ int litIndex; /* Index in the literal pool of the empty
+ * string */
+ Tcl_Obj* depthObj; /* Net stack effect for an error message */
+ Tcl_Obj* resultObj; /* Error message from this procedure */
+ BasicBlock* curr_bb = assemEnvPtr->curr_bb;
+ /* Final basic block in the assembly */
+
+ /*
+ * Don't perform these checks if execution doesn't reach the exit (either
+ * because of an infinite loop or because the only return is from the
+ * middle.
+ */
+
+ if (curr_bb->flags & BB_VISITED) {
+ /*
+ * Exit with no operands; push an empty one.
+ */
+
+ depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
+ if (depth == 0) {
+ /*
+ * Emit a 'push' of the empty literal.
+ */
+
+ litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+
+ /*
+ * Assumes that 'push' is at slot 0 in TalInstructionTable.
+ */
+
+ BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
+ ++depth;
+ }
+
+ /*
+ * Exit with unbalanced stack.
+ */
+
+ if (depth != 1) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ depthObj = Tcl_NewIntObj(depth);
+ Tcl_IncrRefCount(depthObj);
+ resultObj = Tcl_NewStringObj(
+ "stack is unbalanced on exit from the code (depth=",
+ -1);
+ Tcl_AppendObjToObj(resultObj, depthObj);
+ Tcl_DecrRefCount(depthObj);
+ Tcl_AppendToObj(resultObj, ")", -1);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Record stack usage.
+ */
+
+ envPtr->currStackDepth += depth;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ProcessCatches --
+ *
+ * First pass of 'catch' processing.
+ *
+ * Results:
+ * Returns a standard Tcl result, with an appropriate error message if
+ * the result is TCL_ERROR.
+ *
+ * Side effects:
+ * Labels all basic blocks with their enclosing catches.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+ProcessCatches(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ BasicBlock* blockPtr; /* Pointer to a basic block */
+
+ /*
+ * Clear the catch state of all basic blocks.
+ */
+
+ for (blockPtr = assemEnvPtr->head_bb;
+ blockPtr != NULL;
+ blockPtr = blockPtr->successor1) {
+ blockPtr->catchState = BBCS_UNKNOWN;
+ blockPtr->enclosingCatch = NULL;
+ }
+
+ /*
+ * Start the check recursively from the first basic block, which is
+ * outside any exception context
+ */
+
+ if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb,
+ NULL, BBCS_NONE, 0) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check for unclosed catch on exit.
+ */
+
+ if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now there's enough information to build the exception ranges.
+ */
+
+ if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Finally, restore any exception ranges from embedded scripts.
+ */
+
+ RestoreEmbeddedExceptionRanges(assemEnvPtr);
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ProcessCatchesInBasicBlock --
+ *
+ * First-pass catch processing for one basic block.
+ *
+ * Results:
+ * Returns a standard Tcl result, with error message in the interpreter
+ * result if an error occurs.
+ *
+ * This procedure checks consistency of the exception context through the
+ * assembler program, and records the enclosing 'catch' for every basic block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+ProcessCatchesInBasicBlock(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr, /* Basic block being processed */
+ BasicBlock* enclosing, /* Start basic block of the enclosing catch */
+ enum BasicBlockCatchState state,
+ /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */
+ int catchDepth) /* Depth of nesting of catches */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ int result; /* Return value from this procedure */
+ BasicBlock* fallThruEnclosing;
+ /* Enclosing catch if execution falls thru */
+ enum BasicBlockCatchState fallThruState;
+ /* Catch state of the successor block */
+ BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump
+ * target */
+ enum BasicBlockCatchState jumpState;
+ /* Catch state of the jump target */
+ int changed = 0; /* Flag == 1 iff successor blocks need to be
+ * checked because the state of this block has
+ * changed. */
+ BasicBlock* jumpTarget; /* Basic block where a jump goes */
+ Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */
+ Tcl_HashEntry* jtEntry; /* Entry in a jumptable */
+ Tcl_Obj* targetLabel; /* Target label from a jumptable */
+ Tcl_HashEntry* entry; /* Entry from the label table */
+
+ /*
+ * Update the state of the current block, checking for consistency. Set
+ * 'changed' to 1 if the state changes and successor blocks need to be
+ * rechecked.
+ */
+
+ if (bbPtr->catchState == BBCS_UNKNOWN) {
+ bbPtr->enclosingCatch = enclosing;
+ } else if (bbPtr->enclosingCatch != enclosing) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "execution reaches an instruction in inconsistent "
+ "exception contexts", -1));
+ Tcl_SetErrorLine(interp, bbPtr->startLine);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (state > bbPtr->catchState) {
+ bbPtr->catchState = state;
+ changed = 1;
+ }
+
+ /*
+ * If this block has been visited before, and its state hasn't changed,
+ * we're done with it for now.
+ */
+
+ if (!changed) {
+ return TCL_OK;
+ }
+ bbPtr->catchDepth = catchDepth;
+
+ /*
+ * Determine enclosing catch and 'caught' state for the fallthrough and
+ * the jump target. Default for both is the state of the current block.
+ */
+
+ fallThruEnclosing = enclosing;
+ fallThruState = state;
+ jumpEnclosing = enclosing;
+ jumpState = state;
+
+ /* TODO: Make sure that the test cases include validating
+ * that a natural loop can't include 'beginCatch' or 'endCatch' */
+
+ if (bbPtr->flags & BB_BEGINCATCH) {
+ /*
+ * If the block begins a catch, the state for the successor is 'in
+ * catch'. The jump target is the exception exit, and the state of the
+ * jump target is 'caught.'
+ */
+
+ fallThruEnclosing = bbPtr;
+ fallThruState = BBCS_INCATCH;
+ jumpEnclosing = bbPtr;
+ jumpState = BBCS_CAUGHT;
+ ++catchDepth;
+ }
+
+ if (bbPtr->flags & BB_ENDCATCH) {
+ /*
+ * If the block ends a catch, the state for the successor is whatever
+ * the state was on entry to the catch.
+ */
+
+ if (enclosing == NULL) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "endCatch without a corresponding beginCatch", -1));
+ Tcl_SetErrorLine(interp, bbPtr->startLine);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
+ }
+ return TCL_ERROR;
+ }
+ fallThruEnclosing = enclosing->enclosingCatch;
+ fallThruState = enclosing->catchState;
+ --catchDepth;
+ }
+
+ /*
+ * Visit any successor blocks with the appropriate exception context
+ */
+
+ result = TCL_OK;
+ if (bbPtr->flags & BB_FALLTHRU) {
+ result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
+ fallThruEnclosing, fallThruState, catchDepth);
+ }
+ if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(bbPtr->jumpTarget));
+ jumpTarget = Tcl_GetHashValue(entry);
+ result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
+ jumpEnclosing, jumpState, catchDepth);
+ }
+
+ /*
+ * All blocks referenced in a jump table are successors.
+ */
+
+ if (bbPtr->flags & BB_JUMPTABLE) {
+ for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch);
+ result == TCL_OK && jtEntry != NULL;
+ jtEntry = Tcl_NextHashEntry(&jtSearch)) {
+ targetLabel = Tcl_GetHashValue(jtEntry);
+ entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(targetLabel));
+ jumpTarget = Tcl_GetHashValue(entry);
+ result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
+ jumpEnclosing, jumpState, catchDepth);
+ }
+ }
+
+ return result;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckForUnclosedCatches --
+ *
+ * Checks that a sequence of assembly code has no unclosed catches on
+ * exit.
+ *
+ * Results:
+ * Returns a standard Tcl result, with an error message for unclosed
+ * catches.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckForUnclosedCatches(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+
+ if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "catch still active on exit from assembly code", -1));
+ Tcl_SetErrorLine(interp,
+ assemEnvPtr->curr_bb->enclosingCatch->startLine);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BuildExceptionRanges --
+ *
+ * Walks through the assembly code and builds exception ranges for the
+ * catches embedded therein.
+ *
+ * Results:
+ * Returns a standard Tcl result with an error message in the interpreter
+ * if anything is unsuccessful.
+ *
+ * Side effects:
+ * Each contiguous block of code with a given catch exit is assigned an
+ * exception range at the appropriate level.
+ * Exception ranges in embedded blocks have their levels corrected and
+ * collated into the table.
+ * Blocks that end with 'beginCatch' are associated with the innermost
+ * exception range of the following block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+BuildExceptionRanges(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr; /* Current basic block */
+ BasicBlock* prevPtr = NULL; /* Previous basic block */
+ int catchDepth = 0; /* Current catch depth */
+ int maxCatchDepth = 0; /* Maximum catch depth in the program */
+ BasicBlock** catches; /* Stack of catches in progress */
+ int* catchIndices; /* Indices of the exception ranges
+ * of catches in progress */
+ int i;
+
+ /*
+ * Determine the max catch depth for the entire assembly script
+ * (excluding embedded eval's and expr's, which will be handled later).
+ */
+
+ for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
+ if (bbPtr->catchDepth > maxCatchDepth) {
+ maxCatchDepth = bbPtr->catchDepth;
+ }
+ }
+
+ /*
+ * Allocate memory for a stack of active catches.
+ */
+
+ catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*));
+ catchIndices = ckalloc(maxCatchDepth * sizeof(int));
+ for (i = 0; i < maxCatchDepth; ++i) {
+ catches[i] = NULL;
+ catchIndices[i] = -1;
+ }
+
+ /*
+ * Walk through the basic blocks and manage exception ranges.
+ */
+
+ for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
+ UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches,
+ catchIndices);
+ LookForFreshCatches(bbPtr, catches);
+ StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches,
+ catchIndices);
+
+ /*
+ * If the last block was a 'begin catch', fill in the exception range.
+ */
+
+ catchDepth = bbPtr->catchDepth;
+ if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) {
+ TclStoreInt4AtPtr(catchIndices[catchDepth-1],
+ envPtr->codeStart + bbPtr->startOffset - 4);
+ }
+
+ prevPtr = bbPtr;
+ }
+
+ if (catchDepth != 0) {
+ Tcl_Panic("unclosed catch at end of code in "
+ "tclAssembly.c:BuildExceptionRanges, can't happen");
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * UnstackExpiredCatches --
+ *
+ * Unstacks and closes the exception ranges for any catch contexts that
+ * were active in the previous basic block but are inactive in the
+ * current one.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+UnstackExpiredCatches(
+ CompileEnv* envPtr, /* Compilation environment */
+ BasicBlock* bbPtr, /* Basic block being processed */
+ int catchDepth, /* Depth of nesting of catches prior to entry
+ * to this block */
+ BasicBlock** catches, /* Array of catch contexts */
+ int* catchIndices) /* Indices of the exception ranges
+ * corresponding to the catch contexts */
+{
+ ExceptionRange* range; /* Exception range for a specific catch */
+ BasicBlock* catch; /* Catch block being examined */
+ BasicBlockCatchState catchState;
+ /* State of the code relative to the catch
+ * block being examined ("in catch" or
+ * "caught"). */
+
+ /*
+ * Unstack any catches that are deeper than the nesting level of the basic
+ * block being entered.
+ */
+
+ while (catchDepth > bbPtr->catchDepth) {
+ --catchDepth;
+ range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
+ range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
+ catches[catchDepth] = NULL;
+ catchIndices[catchDepth] = -1;
+ }
+
+ /*
+ * Unstack any catches that don't match the basic block being entered,
+ * either because they are no longer part of the context, or because the
+ * context has changed from INCATCH to CAUGHT.
+ */
+
+ catchState = bbPtr->catchState;
+ catch = bbPtr->enclosingCatch;
+ while (catchDepth > 0) {
+ --catchDepth;
+ if (catches[catchDepth] != NULL) {
+ if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) {
+ range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
+ range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
+ catches[catchDepth] = NULL;
+ catchIndices[catchDepth] = -1;
+ }
+ catchState = catch->catchState;
+ catch = catch->enclosingCatch;
+ }
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * LookForFreshCatches --
+ *
+ * Determines whether a basic block being entered needs any exception
+ * ranges that are not already stacked.
+ *
+ * Does not create the ranges: this procedure iterates from the innermost
+ * catch outward, but exception ranges must be created from the outermost
+ * catch inward.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+LookForFreshCatches(
+ BasicBlock* bbPtr, /* Basic block being entered */
+ BasicBlock** catches) /* Array of catch contexts that are already
+ * entered */
+{
+ BasicBlockCatchState catchState;
+ /* State ("in catch" or "caught") of the
+ * current catch. */
+ BasicBlock* catch; /* Current enclosing catch */
+ int catchDepth; /* Nesting depth of the current catch */
+
+ catchState = bbPtr->catchState;
+ catch = bbPtr->enclosingCatch;
+ catchDepth = bbPtr->catchDepth;
+ while (catchDepth > 0) {
+ --catchDepth;
+ if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) {
+ catches[catchDepth] = catch;
+ }
+ catchState = catch->catchState;
+ catch = catch->enclosingCatch;
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * StackFreshCatches --
+ *
+ * Make ExceptionRange records for any catches that are in the basic
+ * block being entered and were not in the previous basic block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+StackFreshCatches(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr, /* Basic block being processed */
+ int catchDepth, /* Depth of nesting of catches prior to entry
+ * to this block */
+ BasicBlock** catches, /* Array of catch contexts */
+ int* catchIndices) /* Indices of the exception ranges
+ * corresponding to the catch contexts */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ ExceptionRange* range; /* Exception range for a specific catch */
+ BasicBlock* catch; /* Catch block being examined */
+ BasicBlock* errorExit; /* Error exit from the catch block */
+ Tcl_HashEntry* entryPtr;
+
+ catchDepth = 0;
+
+ /*
+ * Iterate through the enclosing catch blocks from the outside in,
+ * looking for ones that don't have exception ranges (and are uncaught)
+ */
+
+ for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) {
+ if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) {
+ /*
+ * Create an exception range for a block that needs one.
+ */
+
+ catch = catches[catchDepth];
+ catchIndices[catchDepth] =
+ TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
+ range->nestingLevel = envPtr->exceptDepth + catchDepth;
+ envPtr->maxExceptDepth =
+ TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
+ range->codeOffset = bbPtr->startOffset;
+
+ entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
+ Tcl_GetString(catch->jumpTarget));
+ if (entryPtr == NULL) {
+ Tcl_Panic("undefined label in tclAssembly.c:"
+ "BuildExceptionRanges, can't happen");
+ }
+
+ errorExit = Tcl_GetHashValue(entryPtr);
+ range->catchOffset = errorExit->startOffset;
+ }
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * RestoreEmbeddedExceptionRanges --
+ *
+ * Processes an assembly script, replacing any exception ranges that
+ * were present in embedded code.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+RestoreEmbeddedExceptionRanges(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr; /* Current basic block */
+ int rangeBase; /* Base of the foreign exception ranges when
+ * they are reinstalled */
+ int rangeIndex; /* Index of the current foreign exception
+ * range as reinstalled */
+ ExceptionRange* range; /* Current foreign exception range */
+ unsigned char opcode; /* Current instruction's opcode */
+ int catchIndex; /* Index of the exception range to which the
+ * current instruction refers */
+ int i;
+
+ /*
+ * Walk the basic blocks looking for exceptions in embedded scripts.
+ */
+
+ for (bbPtr = assemEnvPtr->head_bb;
+ bbPtr != NULL;
+ bbPtr = bbPtr->successor1) {
+ if (bbPtr->foreignExceptionCount != 0) {
+ /*
+ * Reinstall the embedded exceptions and track their nesting level
+ */
+
+ rangeBase = envPtr->exceptArrayNext;
+ for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
+ range = bbPtr->foreignExceptions + i;
+ rangeIndex = TclCreateExceptRange(range->type, envPtr);
+ range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
+ memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
+ sizeof(ExceptionRange));
+ if (range->nestingLevel >= envPtr->maxExceptDepth) {
+ envPtr->maxExceptDepth = range->nestingLevel + 1;
+ }
+ }
+
+ /*
+ * Walk through the bytecode of the basic block, and relocate
+ * INST_BEGIN_CATCH4 instructions to the new locations
+ */
+
+ i = bbPtr->startOffset;
+ while (i < bbPtr->successor1->startOffset) {
+ opcode = envPtr->codeStart[i];
+ if (opcode == INST_BEGIN_CATCH4) {
+ catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1);
+ if (catchIndex >= bbPtr->foreignExceptionBase
+ && catchIndex < (bbPtr->foreignExceptionBase +
+ bbPtr->foreignExceptionCount)) {
+ catchIndex -= bbPtr->foreignExceptionBase;
+ catchIndex += rangeBase;
+ TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1);
+ }
+ }
+ i += tclInstructionTable[opcode].numBytes;
+ }
+ }
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ResetVisitedBasicBlocks --
+ *
+ * Turns off the 'visited' flag in all basic blocks at the conclusion
+ * of a pass.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+ResetVisitedBasicBlocks(
+ AssemblyEnv* assemEnvPtr) /* Assembly environment */
+{
+ BasicBlock* block;
+
+ for (block = assemEnvPtr->head_bb; block != NULL;
+ block = block->successor1) {
+ block->flags &= ~BB_VISITED;
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * AddBasicBlockRangeToErrorInfo --
+ *
+ * Updates the error info of the Tcl interpreter to show a given basic
+ * block in the code.
+ *
+ * This procedure is used to label the callstack with source location
+ * information when reporting an error in stack checking.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+AddBasicBlockRangeToErrorInfo(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ BasicBlock* bbPtr) /* Basic block in which the error is found */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Obj* lineNo; /* Line number in the source */
+
+ Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
+ lineNo = Tcl_NewIntObj(bbPtr->startLine);
+ Tcl_IncrRefCount(lineNo);
+ Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ Tcl_AddErrorInfo(interp, " and ");
+ if (bbPtr->successor1 != NULL) {
+ Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
+ Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ } else {
+ Tcl_AddErrorInfo(interp, "end of assembly code");
+ }
+ Tcl_DecrRefCount(lineNo);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * DupAssembleCodeInternalRep --
+ *
+ * Part of the Tcl object type implementation for Tcl assembly language
+ * bytecode. We do not copy the bytecode intrep. Instead, we return
+ * without setting copyPtr->typePtr, so the copy is a plain string copy
+ * of the assembly source, and if it is to be used as a compiled
+ * expression, it will need to be reprocessed.
+ *
+ * This makes sense, because with Tcl's copy-on-write practices, the
+ * usual (only?) time Tcl_DuplicateObj() will be called is when the copy
+ * is about to be modified, which would invalidate any copied bytecode
+ * anyway. The only reason it might make sense to copy the bytecode is if
+ * we had some modifying routines that operated directly on the intrep,
+ * as we do for lists and dicts.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+DupAssembleCodeInternalRep(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr)
+{
+ return;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FreeAssembleCodeInternalRep --
+ *
+ * Part of the Tcl object type implementation for Tcl expression
+ * bytecode. Frees the storage allocated to hold the internal rep, unless
+ * ref counts indicate bytecode execution is still in progress.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May free allocated memory. Leaves objPtr untyped.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+FreeAssembleCodeInternalRep(
+ Tcl_Obj *objPtr)
+{
+ ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index ca18f5e..14804e4 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -118,7 +118,7 @@ Tcl_AsyncCreate(
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
+ asyncPtr = ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
@@ -235,7 +235,7 @@ Tcl_AsyncInvoke(
}
asyncPtr->ready = 0;
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
- code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
+ code = asyncPtr->proc(asyncPtr->clientData, interp, code);
Tcl_MutexLock(&tsdPtr->asyncMutex);
}
tsdPtr->asyncActive = 0;
@@ -260,7 +260,7 @@ Tcl_AsyncInvoke(
* Failure to locate the handler in current thread private list
* of async handlers will result in panic; exception: the list
* is already empty (potential trouble?).
- * Consequently, threads should create and delete handlers
+ * Consequently, threads should create and delete handlers
* themselves. I.e. a handler created by one should not be
* deleted by some other thread.
*
@@ -310,7 +310,7 @@ Tcl_AsyncDelete(
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
- ckfree((char *) asyncPtr);
+ ckfree(asyncPtr);
}
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 71bd45c..2da455b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -10,17 +10,25 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
*
* 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 "tclOOInt.h"
#include "tclCompile.h"
-#include <float.h>
-#include <limits.h>
-#include <math.h>
#include "tommath.h"
+#include <math.h>
+
+#if NRE_ENABLE_ASSERTS
+#include <assert.h>
+#endif
+
+#define INTERP_STACK_INITIAL_SIZE 2000
+#define CORO_STACK_INITIAL_SIZE 200
/*
* Determine whether we're using IEEE floating point
@@ -45,59 +53,134 @@ typedef struct OldMathFuncData {
} OldMathFuncData;
/*
+ * This is the script cancellation struct and hash table. The hash table is
+ * used to keep track of the information necessary to process script
+ * cancellation requests, including the original interp, asynchronous handler
+ * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments
+ * passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is
+ * used for protecting calls to Tcl_CancelEval as well as protecting access to
+ * the hash table below.
+ */
+
+typedef struct {
+ Tcl_Interp *interp; /* Interp this struct belongs to. */
+ Tcl_AsyncHandler async; /* Async handler token for script
+ * cancellation. */
+ char *result; /* The script cancellation result or NULL for
+ * a default result. */
+ int length; /* Length of the above error message. */
+ ClientData clientData; /* Ignored */
+ int flags; /* Additional flags */
+} CancelInfo;
+static Tcl_HashTable cancelTable;
+static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(cancelLock)
+
+/*
+ * Declarations for managing contexts for non-recursive coroutines. Contexts
+ * are used to save the evaluation state between NR calls to each coro.
+ */
+
+static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL};
+
+#define SAVE_CONTEXT(context) \
+ (context).framePtr = iPtr->framePtr; \
+ (context).varFramePtr = iPtr->varFramePtr; \
+ (context).cmdFramePtr = iPtr->cmdFramePtr; \
+ (context).lineLABCPtr = iPtr->lineLABCPtr
+
+#define RESTORE_CONTEXT(context) \
+ iPtr->framePtr = (context).framePtr; \
+ iPtr->varFramePtr = (context).varFramePtr; \
+ iPtr->cmdFramePtr = (context).cmdFramePtr; \
+ iPtr->lineLABCPtr = (context).lineLABCPtr
+
+/*
* Static functions in this file:
*/
-static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
- const char *oldName, const char *newName, int flags);
-static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
-static void DeleteInterpProc(Tcl_Interp *interp);
-static void DeleteOpCmdClientData(ClientData clientData);
-static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command,
- int numChars, int objc, Tcl_Obj *const objv[]);
-static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode);
-static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static void OldMathFuncDeleteProc(ClientData clientData);
-static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprCeilFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprEntierFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprFloorFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprIsqrtFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprSqrtFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp,
- int argc, Tcl_Obj *const *objv);
-static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
- int actual, Tcl_Obj *const *objv);
+static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
+ const char *oldName, const char *newName,
+ int flags);
+static int CancelEvalProc(ClientData clientData,
+ Tcl_Interp *interp, int code);
+static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
+static void DeleteCoroutine(ClientData clientData);
+static void DeleteInterpProc(Tcl_Interp *interp);
+static void DeleteOpCmdClientData(ClientData clientData);
#ifdef USE_DTRACE
-static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-#endif
+static Tcl_ObjCmdProc DTraceObjCmd;
+static Tcl_NRPostProc DTraceCmdReturn;
+#else
+# define DTraceCmdReturn NULL
+#endif /* USE_DTRACE */
+static Tcl_ObjCmdProc ExprAbsFunc;
+static Tcl_ObjCmdProc ExprBinaryFunc;
+static Tcl_ObjCmdProc ExprBoolFunc;
+static Tcl_ObjCmdProc ExprCeilFunc;
+static Tcl_ObjCmdProc ExprDoubleFunc;
+static Tcl_ObjCmdProc ExprEntierFunc;
+static Tcl_ObjCmdProc ExprFloorFunc;
+static Tcl_ObjCmdProc ExprIntFunc;
+static Tcl_ObjCmdProc ExprIsqrtFunc;
+static Tcl_ObjCmdProc ExprRandFunc;
+static Tcl_ObjCmdProc ExprRoundFunc;
+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 NRCoroutineActivateCallback;
+static Tcl_NRPostProc NRCoroutineCallerCallback;
+static Tcl_NRPostProc NRCoroutineExitCallback;
+static Tcl_NRPostProc NRRunObjProc;
+static Tcl_NRPostProc NRTailcallEval;
+static Tcl_ObjCmdProc OldMathFuncProc;
+static void OldMathFuncDeleteProc(ClientData clientData);
+static void ProcessUnexpectedResult(Tcl_Interp *interp,
+ int returnCode);
+static int RewindCoroutine(CoroutineData *corPtr, int result);
+static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
+static void TEOV_PushExceptionHandlers(Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[], int flags);
+static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp,
+ Tcl_Obj *namePtr, Namespace *lookupNsPtr);
+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);
+static Tcl_NRPostProc RewindCoroutineCallback;
+static Tcl_NRPostProc TailcallCleanup;
+static Tcl_NRPostProc TEOEx_ByteCodeCallback;
+static Tcl_NRPostProc TEOEx_ListCallback;
+static Tcl_NRPostProc TEOV_Error;
+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 void ClearTailcall(Tcl_Interp *interp,
+ struct NRE_callback *tailcallPtr);
+static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+
+MODULE_SCOPE const TclStubs tclStubs;
+
+/*
+ * Magical counts for the number of arguments accepted by a coroutine command
+ * after particular kinds of [yield].
+ */
-extern TclStubs tclStubs;
+#define CORO_ACTIVATE_YIELD PTR2INT(NULL)
+#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1
+#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1)
+#define COROUTINE_ARGUMENTS_ARBITRARY (-2)
+
/*
* The following structure define the commands in the Tcl core.
*/
@@ -106,6 +189,7 @@ typedef struct {
const char *name; /* Name of object-based command. */
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. */
@@ -120,93 +204,94 @@ static const CmdInfo builtInCmds[] = {
* Commands in the generic core.
*/
- {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1},
- {"apply", Tcl_ApplyObjCmd, NULL, 1},
- {"array", Tcl_ArrayObjCmd, NULL, 1},
- {"binary", Tcl_BinaryObjCmd, NULL, 1},
- {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1},
+ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1},
+ {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1},
+ {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1},
#ifndef EXCLUDE_OBSOLETE_COMMANDS
- {"case", Tcl_CaseObjCmd, NULL, 1},
+ {"case", Tcl_CaseObjCmd, NULL, NULL, 1},
#endif
- {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1},
- {"concat", Tcl_ConcatObjCmd, NULL, 1},
- {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1},
- {"error", Tcl_ErrorObjCmd, NULL, 1},
- {"eval", Tcl_EvalObjCmd, NULL, 1},
- {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1},
- {"for", Tcl_ForObjCmd, TclCompileForCmd, 1},
- {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1},
- {"format", Tcl_FormatObjCmd, NULL, 1},
- {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1},
- {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1},
- {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1},
- {"join", Tcl_JoinObjCmd, NULL, 1},
- {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1},
- {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1},
- {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1},
- {"linsert", Tcl_LinsertObjCmd, NULL, 1},
- {"list", Tcl_ListObjCmd, TclCompileListCmd, 1},
- {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1},
- {"lrange", Tcl_LrangeObjCmd, NULL, 1},
- {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1},
- {"lreplace", Tcl_LreplaceObjCmd, NULL, 1},
- {"lreverse", Tcl_LreverseObjCmd, NULL, 1},
- {"lsearch", Tcl_LsearchObjCmd, NULL, 1},
- {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1},
- {"lsort", Tcl_LsortObjCmd, NULL, 1},
- {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1},
- {"package", Tcl_PackageObjCmd, NULL, 1},
- {"proc", Tcl_ProcObjCmd, NULL, 1},
- {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1},
- {"regsub", Tcl_RegsubObjCmd, NULL, 1},
- {"rename", Tcl_RenameObjCmd, NULL, 1},
- {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1},
- {"scan", Tcl_ScanObjCmd, NULL, 1},
- {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1},
- {"split", Tcl_SplitObjCmd, NULL, 1},
- {"subst", Tcl_SubstObjCmd, NULL, 1},
- {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1},
- {"trace", Tcl_TraceObjCmd, NULL, 1},
- {"unset", Tcl_UnsetObjCmd, NULL, 1},
- {"uplevel", Tcl_UplevelObjCmd, NULL, 1},
- {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1},
- {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1},
- {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1},
+ {"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, NULL, 1},
+ {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
+ {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
+ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
+ {"format", Tcl_FormatObjCmd, NULL, 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},
+ {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1},
+ {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
+ {"lreplace", Tcl_LreplaceObjCmd, NULL, 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, NULL, 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, NULL, 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, NULL, TclNRYieldObjCmd, 1},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
*/
- {"after", Tcl_AfterObjCmd, NULL, 1},
- {"cd", Tcl_CdObjCmd, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, 1},
- {"eof", Tcl_EofObjCmd, NULL, 1},
- {"encoding", Tcl_EncodingObjCmd, NULL, 0},
- {"exec", Tcl_ExecObjCmd, NULL, 0},
- {"exit", Tcl_ExitObjCmd, NULL, 0},
- {"fblocked", Tcl_FblockedObjCmd, NULL, 1},
- {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0},
- {"fcopy", Tcl_FcopyObjCmd, NULL, 1},
- {"file", Tcl_FileObjCmd, NULL, 0},
- {"fileevent", Tcl_FileEventObjCmd, NULL, 1},
- {"flush", Tcl_FlushObjCmd, NULL, 1},
- {"gets", Tcl_GetsObjCmd, NULL, 1},
- {"glob", Tcl_GlobObjCmd, NULL, 0},
- {"load", Tcl_LoadObjCmd, NULL, 0},
- {"open", Tcl_OpenObjCmd, NULL, 0},
- {"pid", Tcl_PidObjCmd, NULL, 1},
- {"puts", Tcl_PutsObjCmd, NULL, 1},
- {"pwd", Tcl_PwdObjCmd, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, 1},
- {"seek", Tcl_SeekObjCmd, NULL, 1},
- {"socket", Tcl_SocketObjCmd, NULL, 0},
- {"source", Tcl_SourceObjCmd, NULL, 0},
- {"tell", Tcl_TellObjCmd, NULL, 1},
- {"time", Tcl_TimeObjCmd, NULL, 1},
- {"unload", Tcl_UnloadObjCmd, NULL, 0},
- {"update", Tcl_UpdateObjCmd, NULL, 1},
- {"vwait", Tcl_VwaitObjCmd, NULL, 1},
- {NULL, NULL, NULL, 0}
+ {"after", Tcl_AfterObjCmd, NULL, NULL, 1},
+ {"cd", Tcl_CdObjCmd, NULL, NULL, 0},
+ {"close", Tcl_CloseObjCmd, NULL, NULL, 1},
+ {"eof", Tcl_EofObjCmd, NULL, NULL, 1},
+ {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0},
+ {"exec", Tcl_ExecObjCmd, NULL, NULL, 0},
+ {"exit", Tcl_ExitObjCmd, NULL, NULL, 0},
+ {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1},
+ {"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},
+ {"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},
+ {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, 1},
+ {"seek", Tcl_SeekObjCmd, NULL, NULL, 1},
+ {"socket", Tcl_SocketObjCmd, NULL, NULL, 0},
+ {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
+ {"tell", Tcl_TellObjCmd, NULL, NULL, 1},
+ {"time", Tcl_TimeObjCmd, NULL, NULL, 1},
+ {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
+ {"update", Tcl_UpdateObjCmd, NULL, NULL, 1},
+ {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1},
+ {NULL, NULL, NULL, NULL, 0}
};
/*
@@ -215,40 +300,40 @@ static const CmdInfo builtInCmds[] = {
typedef struct {
const char *name; /* Name of the function. The full name is
- * "::tcl::mathfunc::<name>". */
+ * "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
ClientData clientData; /* Client data for the function */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
- { "abs", ExprAbsFunc, NULL },
- { "acos", ExprUnaryFunc, (ClientData) acos },
- { "asin", ExprUnaryFunc, (ClientData) asin },
- { "atan", ExprUnaryFunc, (ClientData) atan },
- { "atan2", ExprBinaryFunc, (ClientData) atan2 },
+ { "abs", ExprAbsFunc, NULL },
+ { "acos", ExprUnaryFunc, (ClientData) acos },
+ { "asin", ExprUnaryFunc, (ClientData) asin },
+ { "atan", ExprUnaryFunc, (ClientData) atan },
+ { "atan2", ExprBinaryFunc, (ClientData) atan2 },
{ "bool", ExprBoolFunc, NULL },
- { "ceil", ExprCeilFunc, NULL },
- { "cos", ExprUnaryFunc, (ClientData) cos },
+ { "ceil", ExprCeilFunc, NULL },
+ { "cos", ExprUnaryFunc, (ClientData) cos },
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
{ "double", ExprDoubleFunc, NULL },
{ "entier", ExprEntierFunc, NULL },
{ "exp", ExprUnaryFunc, (ClientData) exp },
- { "floor", ExprFloorFunc, NULL },
+ { "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, (ClientData) fmod },
- { "hypot", ExprBinaryFunc, (ClientData) hypot },
+ { "hypot", ExprBinaryFunc, (ClientData) hypot },
{ "int", ExprIntFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
- { "log", ExprUnaryFunc, (ClientData) log },
- { "log10", ExprUnaryFunc, (ClientData) log10 },
- { "pow", ExprBinaryFunc, (ClientData) pow },
+ { "log", ExprUnaryFunc, (ClientData) log },
+ { "log10", ExprUnaryFunc, (ClientData) log10 },
+ { "pow", ExprBinaryFunc, (ClientData) pow },
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
- { "sin", ExprUnaryFunc, (ClientData) sin },
- { "sinh", ExprUnaryFunc, (ClientData) sinh },
- { "sqrt", ExprSqrtFunc, NULL },
+ { "sin", ExprUnaryFunc, (ClientData) sin },
+ { "sinh", ExprUnaryFunc, (ClientData) sinh },
+ { "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
- { "tan", ExprUnaryFunc, (ClientData) tan },
- { "tanh", ExprUnaryFunc, (ClientData) tanh },
- { "wide", ExprWideFunc, NULL },
+ { "tan", ExprUnaryFunc, (ClientData) tan },
+ { "tanh", ExprUnaryFunc, (ClientData) tanh },
+ { "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
@@ -317,47 +402,33 @@ static const OpCmdInfo mathOpCmds[] = {
{ NULL, NULL, NULL,
{0}, NULL}
};
-
-/*
- * Macros for stack checks. The goal of these macros is to allow the size of
- * the stack to be checked (so preventing overflow) in a *cheap* way. Note
- * that the check needs to be (amortized) cheap since it is on the critical
- * path for recursion.
- */
-
-#if defined(TCL_NO_STACK_CHECK)
-/*
- * Stack check disabled: make them noops.
- */
-
-# define CheckCStack(interp, localIntPtr) 1
-# define GetCStackParams(iPtr) /* do nothing */
-#elif defined(TCL_CROSS_COMPILE)
-
+
/*
- * This variable is static and only set *once*, during library initialization.
- * It therefore needs no thread guards.
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEvaluation --
+ *
+ * Finalizes the script cancellation hash table.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
*/
-static int stackGrowsDown = 1;
-# define GetCStackParams(iPtr) \
- stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound))
-# define CheckCStack(iPtr, localIntPtr) \
- (stackGrowsDown \
- ? ((localIntPtr) > (iPtr)->stackBound) \
- : ((localIntPtr) < (iPtr)->stackBound) \
- )
-#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */
-# define GetCStackParams(iPtr) \
- TclpGetCStackParams(&((iPtr)->stackBound))
-# ifdef TCL_STACK_GROWS_UP
-# define CheckCStack(iPtr, localIntPtr) \
- (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound)
-# else /* TCL_STACK_GROWS_UP */
-# define CheckCStack(iPtr, localIntPtr) \
- ((localIntPtr) > (iPtr)->stackBound)
-# endif /* TCL_STACK_GROWS_UP */
-#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */
+void
+TclFinalizeEvaluation(void)
+{
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized == 1) {
+ Tcl_DeleteHashTable(&cancelTable);
+ cancelTableInitialized = 0;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+}
/*
*----------------------------------------------------------------------
@@ -387,6 +458,9 @@ Tcl_CreateInterp(void)
const OpCmdInfo *opcmdInfoPtr;
const CmdInfo *cmdInfoPtr;
Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+ CancelInfo *cancelInfo;
union {
char c[sizeof(short)];
short s;
@@ -410,13 +484,22 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
+ if (cancelTableInitialized == 0) {
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized == 0) {
+ Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
+ cancelTableInitialized = 1;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
* object type table and other object management code.
*/
- iPtr = (Interp *) ckalloc(sizeof(Interp));
+ iPtr = ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
iPtr->result = iPtr->resultSpace;
@@ -435,15 +518,15 @@ Tcl_CreateInterp(void)
iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */
/*
- * TIP #280 - Initialize the arrays used to extend the ByteCode and
- * Proc structures.
+ * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
+ * structures.
*/
iPtr->cmdFramePtr = NULL;
- iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
- iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
+ iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
@@ -456,6 +539,17 @@ Tcl_CreateInterp(void)
iPtr->errorInfo = NULL;
TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
Tcl_IncrRefCount(iPtr->eiVar);
+ iPtr->errorStack = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(iPtr->errorStack);
+ iPtr->resetErrorStack = 1;
+ TclNewLiteralStringObj(iPtr->upLiteral,"UP");
+ Tcl_IncrRefCount(iPtr->upLiteral);
+ TclNewLiteralStringObj(iPtr->callLiteral,"CALL");
+ Tcl_IncrRefCount(iPtr->callLiteral);
+ TclNewLiteralStringObj(iPtr->innerLiteral,"INNER");
+ Tcl_IncrRefCount(iPtr->innerLiteral);
+ iPtr->innerContext = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(iPtr->innerContext);
iPtr->errorCode = NULL;
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
Tcl_IncrRefCount(iPtr->ecVar);
@@ -480,7 +574,7 @@ Tcl_CreateInterp(void)
}
iPtr->cmdCount = 0;
- TclInitLiteralTable(&(iPtr->literalTable));
+ TclInitLiteralTable(&iPtr->literalTable);
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
@@ -530,7 +624,7 @@ Tcl_CreateInterp(void)
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
- framePtr = (CallFrame *) ckalloc(sizeof(CallFrame));
+ framePtr = ckalloc(sizeof(CallFrame));
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
@@ -549,7 +643,7 @@ Tcl_CreateInterp(void)
* variable).
*/
- iPtr->execEnvPtr = TclCreateExecEnv(interp);
+ iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE);
/*
* TIP #219, Tcl Channel Reflection API support.
@@ -558,25 +652,44 @@ Tcl_CreateInterp(void)
iPtr->chanMsg = NULL;
/*
+ * TIP #285, Script cancellation support.
+ */
+
+ iPtr->asyncCancelMsg = Tcl_NewObj();
+
+ cancelInfo = ckalloc(sizeof(CancelInfo));
+ cancelInfo->interp = interp;
+
+ iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
+ cancelInfo->async = iPtr->asyncCancel;
+ cancelInfo->result = NULL;
+ cancelInfo->length = 0;
+
+ Tcl_MutexLock(&cancelLock);
+ hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cancelInfo);
+ Tcl_MutexUnlock(&cancelLock);
+
+ /*
* Initialize the compilation and execution statistics kept for this
* interpreter.
*/
#ifdef TCL_COMPILE_STATS
- statsPtr = &(iPtr->stats);
+ statsPtr = &iPtr->stats;
statsPtr->numExecutions = 0;
statsPtr->numCompilations = 0;
statsPtr->numByteCodesFreed = 0;
- (void) memset(statsPtr->instructionCount, 0,
+ memset(statsPtr->instructionCount, 0,
sizeof(statsPtr->instructionCount));
statsPtr->totalSrcBytes = 0.0;
statsPtr->totalByteCodeBytes = 0.0;
statsPtr->currentSrcBytes = 0.0;
statsPtr->currentByteCodeBytes = 0.0;
- (void) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
- (void) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount));
- (void) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount));
+ memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
+ memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount));
+ memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount));
statsPtr->currentInstBytes = 0.0;
statsPtr->currentLitBytes = 0.0;
@@ -587,7 +700,7 @@ Tcl_CreateInterp(void)
statsPtr->numLiteralsCreated = 0;
statsPtr->totalLitStringBytes = 0.0;
statsPtr->currentLitStringBytes = 0.0;
- (void) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
+ memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
@@ -611,7 +724,8 @@ Tcl_CreateInterp(void)
TclInitLimitSupport(interp);
/*
- * Initialise the thread-specific data ekeko.
+ * Initialise the thread-specific data ekeko. Note that the thread's alloc
+ * cache was already initialised by the call to alloc the interp struct.
*/
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
@@ -621,13 +735,7 @@ Tcl_CreateInterp(void)
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
-
- /*
- * Insure that the stack checking mechanism for this interp is
- * initialized.
- */
-
- GetCStackParams(iPtr);
+ iPtr->deferredCallbacks = NULL;
/*
* Create the core commands. Do it here, rather than calling
@@ -640,19 +748,17 @@ Tcl_CreateInterp(void)
* Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
*/
- for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
- int isNew;
- Tcl_HashEntry *hPtr;
-
+ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if ((cmdInfoPtr->objProc == NULL)
- && (cmdInfoPtr->compileProc == NULL)) {
+ && (cmdInfoPtr->compileProc == NULL)
+ && (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
- cmdPtr = (Command *) ckalloc(sizeof(Command));
+ cmdPtr = ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
@@ -667,20 +773,27 @@ Tcl_CreateInterp(void)
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = cmdInfoPtr->nreProc;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
/*
- * Create the "chan", "dict", "info" and "string" ensembles. Note that all
- * these commands (and their subcommands that are not present in the
- * global namespace) are wholly safe.
+ * Create the "array", "binary", "chan", "dict", "file", "info",
+ * "namespace" and "string" ensembles. Note that all these commands (and
+ * their subcommands that are not present in the global namespace) are
+ * wholly safe *except* for "file".
*/
+ TclInitArrayCmd(interp);
+ TclInitBinaryCmd(interp);
TclInitChanCmd(interp);
TclInitDictCmd(interp);
+ TclInitFileCmd(interp);
TclInitInfoCmd(interp);
+ TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
+ TclInitPrefixCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -703,12 +816,27 @@ Tcl_CreateInterp(void)
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
- * Create an unsupported command for debugging bytecode.
+ * Create unsupported commands for debugging bytecode and objects.
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
-
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
+ Tcl_RepresentationCmd, NULL, NULL);
+
+ /* Adding the bytecode assembler command */
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
+ "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
+ TclNRAssembleObjCmd, NULL, NULL);
+ cmdPtr->compileProc = &TclCompileAssembleCmd;
+
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
+ TclNRYieldToObjCmd, NULL, NULL);
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
+ TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
+ NRCoroInjectObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -725,8 +853,8 @@ Tcl_CreateInterp(void)
if (mathfuncNSPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
- strcpy(mathFuncName, "::tcl::mathfunc::");
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
+ memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
@@ -740,15 +868,14 @@ Tcl_CreateInterp(void)
*/
mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
-#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
if (mathopNSPtr == NULL) {
Tcl_Panic("can't create math operator namespace");
}
- (void) Tcl_Export(interp, mathopNSPtr, "*", 1);
- strcpy(mathFuncName, "::tcl::mathop::");
+ Tcl_Export(interp, mathopNSPtr, "*", 1);
+#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
+ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
- TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)
- ckalloc(sizeof(TclOpCmdClientData));
+ TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));
occdPtr->op = opcmdInfoPtr->name;
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
@@ -822,15 +949,26 @@ Tcl_CreateInterp(void)
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
-#ifdef Tcl_InitStubs
-#undef Tcl_InitStubs
-#endif
- Tcl_InitStubs(interp, TCL_VERSION, 1);
-
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ if (TclOOInit(interp) != TCL_OK) {
+ Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+
+ /*
+ * Only build in zlib support if we've successfully detected a library to
+ * compile and link against.
+ */
+
+#ifdef HAVE_ZLIB
+ if (TclZlibInit(interp) != TCL_OK) {
+ Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+#endif
+
+ TOP_CB(iPtr) = NULL;
return interp;
}
@@ -840,7 +978,7 @@ DeleteOpCmdClientData(
{
TclOpCmdClientData *occdPtr = clientData;
- ckfree((char *) occdPtr);
+ ckfree(occdPtr);
}
/*
@@ -873,6 +1011,7 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
+ TclMakeFileCommandSafe(interp); /* Ugh! */
return TCL_OK;
}
@@ -910,14 +1049,14 @@ Tcl_CallWhenDeleted(
Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
- AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+ AssocData *dPtr = ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == NULL) {
- iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
@@ -964,9 +1103,9 @@ Tcl_DontCallWhenDeleted(
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ dPtr = Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
- ckfree((char *) dPtr);
+ ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
return;
}
@@ -1006,14 +1145,14 @@ Tcl_SetAssocData(
int isNew;
if (iPtr->assocData == NULL) {
- iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
if (isNew == 0) {
dPtr = Tcl_GetHashValue(hPtr);
} else {
- dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+ dPtr = ckalloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
@@ -1058,7 +1197,7 @@ Tcl_DeleteAssocData(
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
- ckfree((char *) dPtr);
+ ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
}
@@ -1213,6 +1352,7 @@ DeleteInterpProc(
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
+ int i;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
@@ -1241,6 +1381,37 @@ DeleteInterpProc(
}
/*
+ * TIP #285, Script cancellation support. Delete this interp from the
+ * global hash table of CancelInfo structs.
+ */
+
+ Tcl_MutexLock(&cancelLock);
+ hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ if (hPtr != NULL) {
+ CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr);
+
+ if (cancelInfo != NULL) {
+ if (cancelInfo->result != NULL) {
+ ckfree(cancelInfo->result);
+ }
+ ckfree(cancelInfo);
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ if (iPtr->asyncCancel != NULL) {
+ Tcl_AsyncDelete(iPtr->asyncCancel);
+ iPtr->asyncCancel = NULL;
+ }
+
+ if (iPtr->asyncCancelMsg != NULL) {
+ Tcl_DecrRefCount(iPtr->asyncCancelMsg);
+ iPtr->asyncCancelMsg = NULL;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+
+ /*
* Shut down all limit handler callback scripts that call back into this
* interpreter. Then eliminate all limit handlers for this interpreter.
*/
@@ -1257,7 +1428,7 @@ DeleteInterpProc(
* table, as it will be freed later in this function without further use.
*/
- TclCleanupLiteralTable(interp, &(iPtr->literalTable));
+ TclCleanupLiteralTable(interp, &iPtr->literalTable);
TclHandleFree(iPtr->handle);
TclTeardownNamespace(iPtr->globalNsPtr);
@@ -1270,17 +1441,16 @@ DeleteInterpProc(
/*
* Non-pernicious deletion. The deletion callbacks will not be allowed
* to create any new hidden or non-hidden commands.
- * Tcl_DeleteCommandFromToken() will remove the entry from the
+ * Tcl_DeleteCommandFromToken will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- Tcl_DeleteCommandFromToken(interp,
- (Tcl_Command) Tcl_GetHashValue(hPtr));
+ Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
- ckfree((char *) hTablePtr);
+ ckfree(hTablePtr);
}
/*
@@ -1301,10 +1471,10 @@ DeleteInterpProc(
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
- ckfree((char *) dPtr);
+ ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
- ckfree((char *) hTablePtr);
+ ckfree(hTablePtr);
}
/*
@@ -1316,7 +1486,7 @@ DeleteInterpProc(
Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
}
Tcl_PopCallFrame(interp);
- ckfree((char *) iPtr->rootFramePtr);
+ ckfree(iPtr->rootFramePtr);
iPtr->rootFramePtr = NULL;
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
@@ -1326,7 +1496,7 @@ DeleteInterpProc(
*/
Tcl_FreeResult(interp);
- interp->result = NULL;
+ iPtr->result = NULL;
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
Tcl_DecrRefCount(iPtr->ecVar);
@@ -1339,6 +1509,12 @@ DeleteInterpProc(
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
+ Tcl_DecrRefCount(iPtr->errorStack);
+ iPtr->errorStack = NULL;
+ Tcl_DecrRefCount(iPtr->upLiteral);
+ Tcl_DecrRefCount(iPtr->callLiteral);
+ Tcl_DecrRefCount(iPtr->innerLiteral);
+ Tcl_DecrRefCount(iPtr->innerContext);
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
@@ -1360,7 +1536,7 @@ DeleteInterpProc(
while (resPtr) {
nextResPtr = resPtr->nextPtr;
ckfree(resPtr->name);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
resPtr = nextResPtr;
}
@@ -1369,101 +1545,99 @@ DeleteInterpProc(
* interpreter.
*/
- TclDeleteLiteralTable(interp, &(iPtr->literalTable));
+ TclDeleteLiteralTable(interp, &iPtr->literalTable);
/*
* TIP #280 - Release the arrays for ByteCode/Proc extension, and
* contents.
*/
- {
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch hSearch;
- int i;
-
- for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
+ for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
- }
- ckfree((char *) cfPtr->line);
- ckfree((char *) cfPtr);
- Tcl_DeleteHashEntry(hPtr);
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
}
- Tcl_DeleteHashTable(iPtr->linePBodyPtr);
- ckfree((char *) iPtr->linePBodyPtr);
- iPtr->linePBodyPtr = NULL;
+ ckfree(cfPtr->line);
+ ckfree(cfPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(iPtr->linePBodyPtr);
+ ckfree(iPtr->linePBodyPtr);
+ iPtr->linePBodyPtr = NULL;
- /*
- * See also tclCompile.c, TclCleanupByteCode
- */
+ /*
+ * See also tclCompile.c, TclCleanupByteCode
+ */
- for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- ExtCmdLoc *eclPtr = (ExtCmdLoc *) Tcl_GetHashValue(hPtr);
+ for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr);
- 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->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((char *) eclPtr->loc);
- }
+ if (eclPtr->loc != NULL) {
+ ckfree(eclPtr->loc);
+ }
- Tcl_DeleteHashTable (&eclPtr->litInfo);
+ Tcl_DeleteHashTable(&eclPtr->litInfo);
- ckfree((char *) eclPtr);
- Tcl_DeleteHashEntry(hPtr);
- }
- Tcl_DeleteHashTable(iPtr->lineBCPtr);
- ckfree((char *) iPtr->lineBCPtr);
- iPtr->lineBCPtr = NULL;
+ ckfree(eclPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(iPtr->lineBCPtr);
+ ckfree(iPtr->lineBCPtr);
+ iPtr->lineBCPtr = NULL;
+ /*
+ * Location stack for uplevel/eval/... scripts which were passed through
+ * proc arguments. Actually we track all arguments as we do not and cannot
+ * know which arguments will be used as scripts and which will not.
+ */
+
+ if (iPtr->lineLAPtr->numEntries) {
/*
- * Location stack for uplevel/eval/... scripts which were passed
- * through proc arguments. Actually we track all arguments as we
- * don't, cannot know which arguments will be used as scripts and
- * which won't.
+ * When the interp goes away we have nothing on the stack, so there
+ * are no arguments, so this table has to be empty.
*/
- if (iPtr->lineLAPtr->numEntries) {
- /*
- * When the interp goes away we have nothing on the stack, so
- * there are no arguments, so this table has to be empty.
- */
+ Tcl_Panic("Argument location tracking table not empty");
+ }
- Tcl_Panic ("Argument location tracking table not empty");
- }
+ Tcl_DeleteHashTable(iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
+ iPtr->lineLAPtr = NULL;
- Tcl_DeleteHashTable (iPtr->lineLAPtr);
- ckfree((char*) iPtr->lineLAPtr);
- iPtr->lineLAPtr = NULL;
+ if (iPtr->lineLABCPtr->numEntries) {
+ /*
+ * When the interp goes away we have nothing on the stack, so there
+ * are no arguments, so this table has to be empty.
+ */
- if (iPtr->lineLABCPtr->numEntries) {
- /*
- * When the interp goes away we have nothing on the stack, so
- * there are no arguments, so this table has to be empty.
- */
+ Tcl_Panic("Argument location tracking table not empty");
+ }
- Tcl_Panic ("Argument location tracking table not empty");
- }
+ Tcl_DeleteHashTable(iPtr->lineLABCPtr);
+ ckfree(iPtr->lineLABCPtr);
+ iPtr->lineLABCPtr = NULL;
- Tcl_DeleteHashTable (iPtr->lineLABCPtr);
- ckfree((char*) iPtr->lineLABCPtr);
- iPtr->lineLABCPtr = NULL;
- }
+ /*
+ * Squelch the tables of traces on variables and searches over arrays in
+ * the in the interpreter.
+ */
Tcl_DeleteHashTable(&iPtr->varTraces);
Tcl_DeleteHashTable(&iPtr->varSearches);
- ckfree((char *) iPtr);
+ ckfree(iPtr);
}
/*
@@ -1532,6 +1706,7 @@ Tcl_HideCommand(
Tcl_AppendResult(interp,
"cannot use namespace qualifiers in hidden command"
" token (rename)", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
return TCL_ERROR;
}
@@ -1555,6 +1730,7 @@ Tcl_HideCommand(
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendResult(interp, "can only hide global namespace commands"
" (use rename then hide)", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1564,8 +1740,7 @@ Tcl_HideCommand(
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
- hiddenCmdTablePtr = (Tcl_HashTable *)
- ckalloc((unsigned) sizeof(Tcl_HashTable));
+ hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
@@ -1580,6 +1755,7 @@ Tcl_HideCommand(
if (!isNew) {
Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
"\" already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
return TCL_ERROR;
}
@@ -1682,6 +1858,7 @@ Tcl_ExposeCommand(
if (strstr(cmdName, "::") != NULL) {
Tcl_AppendResult(interp, "cannot expose to a namespace "
"(use expose to toplevel, then rename)", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1697,24 +1874,26 @@ Tcl_ExposeCommand(
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
+ hiddenCmdToken, NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace command (enforced by
- * Tcl_HideCommand() but let's double check. (If it was not, we would not
+ * Tcl_HideCommand but let's double check. (If it was not, we would not
* really know how to handle it).
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
/*
- * This case is theoritically impossible, we might rather Tcl_Panic()
+ * This case is theoritically impossible, we might rather Tcl_Panic
* than 'nicely' erroring out ?
*/
Tcl_AppendResult(interp,
- "trying to expose a non global command name space command",
+ "trying to expose a non-global command namespace command",
NULL);
return TCL_ERROR;
}
@@ -1734,6 +1913,7 @@ Tcl_ExposeCommand(
if (!isNew) {
Tcl_AppendResult(interp, "exposed command \"", cmdName,
"\" already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
return TCL_ERROR;
}
@@ -1881,7 +2061,7 @@ Tcl_CreateCommand(
* stuck in an infinite loop).
*/
- ckfree((char *) Tcl_GetHashValue(hPtr));
+ ckfree(Tcl_GetHashValue(hPtr));
}
} else {
/*
@@ -1893,7 +2073,7 @@ Tcl_CreateCommand(
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
- cmdPtr = (Command *) ckalloc(sizeof(Command));
+ cmdPtr = ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
@@ -1909,6 +2089,7 @@ Tcl_CreateCommand(
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = NULL;
/*
* Plug in any existing import references found above. Be sure to update
@@ -1975,7 +2156,7 @@ Tcl_CreateObjCommand(
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
ClientData clientData, /* Arbitrary value to pass to object
- * function. */
+ * function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
@@ -2053,7 +2234,7 @@ Tcl_CreateObjCommand(
* stuck in an infinite loop).
*/
- ckfree(Tcl_GetHashValue(hPtr));
+ ckfree(Tcl_GetHashValue(hPtr));
}
} else {
/*
@@ -2064,7 +2245,7 @@ Tcl_CreateObjCommand(
TclInvalidateNsCmdLookup(nsPtr);
}
- cmdPtr = (Command *) ckalloc(sizeof(Command));
+ cmdPtr = ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
@@ -2080,6 +2261,7 @@ Tcl_CreateObjCommand(
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = NULL;
/*
* Plug in any existing import references found above. Be sure to update
@@ -2137,10 +2319,10 @@ TclInvokeStringCommand(
{
Command *cmdPtr = clientData;
int i, result;
- const char **argv = (const char **)
+ const char **argv =
TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
+ for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
@@ -2149,7 +2331,7 @@ TclInvokeStringCommand(
* Invoke the command's string-based Tcl_CmdProc.
*/
- result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
+ result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv);
TclStackFree(interp, (void *) argv);
return result;
@@ -2183,13 +2365,13 @@ TclInvokeObjectCommand(
int argc, /* Number of arguments. */
register const char **argv) /* Argument strings. */
{
- Command *cmdPtr = (Command *) clientData;
+ Command *cmdPtr = clientData;
Tcl_Obj *objPtr;
int i, length, result;
- Tcl_Obj **objv = (Tcl_Obj **)
+ Tcl_Obj **objv =
TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *)));
- for (i = 0; i < argc; i++) {
+ for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewStringObj(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
@@ -2200,7 +2382,12 @@ TclInvokeObjectCommand(
* Invoke the command's object-based Tcl_ObjCmdProc.
*/
- result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
+ if (cmdPtr->objProc != NULL) {
+ result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv);
+ } else {
+ result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
+ cmdPtr->objClientData, argc, objv);
+ }
/*
* Move the interpreter's object result to the string result, then reset
@@ -2214,7 +2401,7 @@ TclInvokeObjectCommand(
* free the objv array if malloc'ed storage was used.
*/
- for (i = 0; i < argc; i++) {
+ for (i = 0; i < argc; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
@@ -2273,6 +2460,7 @@ TclRenameCommand(
Tcl_AppendResult(interp, "can't ",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
" \"", oldName, "\": command doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
cmdNsPtr = cmdPtr->nsPtr;
@@ -2303,19 +2491,22 @@ TclRenameCommand(
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_AppendResult(interp, "can't rename to \"", newName,
"\": bad command name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
Tcl_AppendResult(interp, "can't rename to \"", newName,
"\": command already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
+ "TARGET_EXISTS", NULL);
result = TCL_ERROR;
goto done;
}
/*
* Warning: any changes done in the code here are likely to be needed in
- * Tcl_HideCommand() code too (until the common parts are extracted out).
+ * Tcl_HideCommand code too (until the common parts are extracted out).
* - dl
*/
@@ -2474,7 +2665,7 @@ Tcl_SetCommandInfoFromToken(
{
Command *cmdPtr; /* Internal representation of the command */
- if (cmd == (Tcl_Command) NULL) {
+ if (cmd == NULL) {
return 0;
}
@@ -2488,8 +2679,12 @@ Tcl_SetCommandInfoFromToken(
if (infoPtr->objProc == NULL) {
cmdPtr->objProc = TclInvokeStringCommand;
cmdPtr->objClientData = cmdPtr;
+ cmdPtr->nreProc = NULL;
} else {
- cmdPtr->objProc = infoPtr->objProc;
+ if (infoPtr->objProc != cmdPtr->objProc) {
+ cmdPtr->nreProc = NULL;
+ cmdPtr->objProc = infoPtr->objProc;
+ }
cmdPtr->objClientData = infoPtr->objClientData;
}
cmdPtr->deleteProc = infoPtr->deleteProc;
@@ -2554,7 +2749,7 @@ Tcl_GetCommandInfoFromToken(
{
Command *cmdPtr; /* Internal representation of the command */
- if (cmd == (Tcl_Command) NULL) {
+ if (cmd == NULL) {
return 0;
}
@@ -2699,7 +2894,7 @@ Tcl_DeleteCommand(
*/
cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
- if (cmd == (Tcl_Command) NULL) {
+ if (cmd == NULL) {
return -1;
}
return Tcl_DeleteCommandFromToken(interp, cmd);
@@ -2794,8 +2989,9 @@ Tcl_DeleteCommandFromToken(
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
+
if ((--tracePtr->refCount) <= 0) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
tracePtr = nextPtr;
}
@@ -2829,19 +3025,17 @@ Tcl_DeleteCommandFromToken(
* created when a command was imported into a namespace, this client
* data will be a pointer to a ImportedCmdData structure describing
* the "real" command that this imported command refers to.
- */
-
- /*
+ *
* If you are getting a crash during the call to deleteProc and
* cmdPtr->deleteProc is a pointer to the function free(), the most
* likely cause is that your extension allocated memory for the
- * clientData argument to Tcl_CreateObjCommand() with the ckalloc()
+ * clientData argument to Tcl_CreateObjCommand with the ckalloc()
* macro and you are now trying to deallocate this memory with free()
* instead of ckfree(). You should pass a pointer to your own method
* that calls ckfree().
*/
- (*cmdPtr->deleteProc)(cmdPtr->deleteData);
+ cmdPtr->deleteProc(cmdPtr->deleteData);
}
/*
@@ -2850,7 +3044,7 @@ Tcl_DeleteCommandFromToken(
* imported commands now.
*/
- for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
+ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
refPtr = nextRefPtr) {
nextRefPtr = refPtr->nextPtr;
importCmd = (Tcl_Command) refPtr->importedCmdPtr;
@@ -2870,11 +3064,10 @@ Tcl_DeleteCommandFromToken(
}
/*
- * Mark the Command structure as no longer valid. This allows
- * TclExecuteByteCode to recognize when a Command has logically been
- * deleted and a pointer to this Command structure cached in a CmdName
- * object is invalid. TclExecuteByteCode will look up the command again in
- * the interpreter's command hashtable.
+ * A number of tests for particular kinds of commands are done by checking
+ * whether the objProc field holds a known value. Set the field to NULL so
+ * that such tests won't have false positives when applied to deleted
+ * commands.
*/
cmdPtr->objProc = NULL;
@@ -2884,7 +3077,7 @@ Tcl_DeleteCommandFromToken(
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
- * CmdName Command reference is found to be invalid and TclExecuteByteCode
+ * CmdName Command reference is found to be invalid and TclNRExecuteByteCode
* looks up the command in the command hashtable).
*/
@@ -2892,6 +3085,23 @@ Tcl_DeleteCommandFromToken(
return 0;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * CallCommandTraces --
+ *
+ * Abstraction of the code to call traces on a command.
+ *
+ * Results:
+ * Currently always NULL.
+ *
+ * Side effects:
+ * Anything; this may recursively evaluate scripts and code exists to do
+ * just that.
+ *
+ *----------------------------------------------------------------------
+ */
+
static char *
CallCommandTraces(
Interp *iPtr, /* Interpreter containing command. */
@@ -2962,11 +3172,11 @@ CallCommandTraces(
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
}
- (*tracePtr->traceProc)(tracePtr->clientData,
- (Tcl_Interp *) iPtr, oldName, newName, flags);
+ tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
+ oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
if ((--tracePtr->refCount) <= 0) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
}
@@ -2993,7 +3203,84 @@ CallCommandTraces(
Tcl_Release(iPtr);
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CancelEvalProc --
+ *
+ * Marks this interpreter as being canceled. This causes current
+ * executions to be unwound as the interpreter enters a state where it
+ * refuses to execute more commands or handle [catch] or [try], yet the
+ * interpreter is still able to execute further commands after the
+ * cancelation is cleared (unlike if it is deleted).
+ *
+ * Results:
+ * The value given for the code argument.
+ *
+ * Side effects:
+ * Transfers a message from the cancelation message to the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CancelEvalProc(
+ ClientData clientData, /* Interp to cancel the script in progress. */
+ Tcl_Interp *interp, /* Ignored */
+ int code) /* Current return code from command. */
+{
+ CancelInfo *cancelInfo = clientData;
+ Interp *iPtr;
+
+ if (cancelInfo != NULL) {
+ Tcl_MutexLock(&cancelLock);
+ iPtr = (Interp *) cancelInfo->interp;
+
+ if (iPtr != NULL) {
+ /*
+ * Setting the CANCELED flag will cause the script in progress to
+ * be canceled as soon as possible. The core honors this flag at
+ * all the necessary places to ensure script cancellation is
+ * responsive. Extensions can check for this flag by calling
+ * Tcl_Canceled and checking if TCL_ERROR is returned or they can
+ * choose to ignore the script cancellation flag and the
+ * associated functionality altogether. Currently, the only other
+ * flag we care about here is the TCL_CANCEL_UNWIND flag (from
+ * Tcl_CancelEval). We do not want to simply combine all the flags
+ * from original Tcl_CancelEval call with the interp flags here
+ * just in case the caller passed flags that might cause behaviour
+ * unrelated to script cancellation.
+ */
+
+ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED);
+
+ /*
+ * Now, we must set the script cancellation flags on all the slave
+ * interpreters belonging to this one.
+ */
+
+ TclSetSlaveCancelFlags((Tcl_Interp *) iPtr,
+ cancelInfo->flags | CANCELED, 0);
+
+ /*
+ * Create the result object now so that Tcl_Canceled can avoid
+ * locking the cancelLock mutex.
+ */
+
+ if (cancelInfo->result != NULL) {
+ Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result,
+ cancelInfo->length);
+ } else {
+ Tcl_SetObjLength(iPtr->asyncCancelMsg, 0);
+ }
+ }
+ Tcl_MutexUnlock(&cancelLock);
+ }
+ return code;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -3001,7 +3288,15 @@ CallCommandTraces(
*
* 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.
+ * 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.
*
*----------------------------------------------------------------------
*/
@@ -3009,18 +3304,41 @@ CallCommandTraces(
static Tcl_Obj *
GetCommandSource(
Interp *iPtr,
- const char *command,
- int numChars,
int objc,
- Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[],
+ int lookup)
{
- if (!command) {
- return Tcl_NewListObj(objc, objv);
- }
- if (command == (char *) -1) {
- command = TclGetSrcInfoForCmd(iPtr, &numChars);
+ 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);
+ }
}
- return Tcl_NewStringObj(command, numChars);
+ Tcl_IncrRefCount(objPtr);
+ return objPtr;
}
/*
@@ -3051,7 +3369,7 @@ TclCleanupCommand(
{
cmdPtr->refCount--;
if (cmdPtr->refCount <= 0) {
- ckfree((char *) cmdPtr);
+ ckfree(cmdPtr);
}
}
@@ -3092,13 +3410,11 @@ Tcl_CreateMathFunc(
* function. */
{
Tcl_DString bigName;
- OldMathFuncData *data = (OldMathFuncData *)
- ckalloc(sizeof(OldMathFuncData));
+ OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData));
data->proc = proc;
data->numArgs = numArgs;
- data->argTypes = (Tcl_ValueType *)
- ckalloc(numArgs * sizeof(Tcl_ValueType));
+ data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
@@ -3155,10 +3471,9 @@ OldMathFuncProc(
* Convert arguments from Tcl_Obj's to Tcl_Value's.
*/
- args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
+ args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
-
- /* TODO: Convert to TclGetNumberFromObj() ? */
+ /* TODO: Convert to TclGetNumberFromObj? */
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
@@ -3172,10 +3487,11 @@ OldMathFuncProc(
* We have a non-numeric argument.
*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "argument to math function didn't have numeric value",-1));
+ Tcl_SetResult(interp,
+ "argument to math function didn't have numeric value",
+ TCL_STATIC);
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
- ckfree((char *)args);
+ ckfree(args);
return TCL_ERROR;
}
@@ -3189,12 +3505,12 @@ OldMathFuncProc(
args[k].type = dataPtr->argTypes[k];
switch (args[k].type) {
case TCL_EITHER:
- if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue))
+ if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue)
== TCL_OK) {
args[k].type = TCL_INT;
break;
}
- if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue))
+ if (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue)
== TCL_OK) {
args[k].type = TCL_WIDE_INT;
break;
@@ -3206,21 +3522,21 @@ OldMathFuncProc(
args[k].doubleValue = d;
break;
case TCL_INT:
- if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
- ckfree((char *)args);
+ if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
+ ckfree(args);
return TCL_ERROR;
}
valuePtr = Tcl_GetObjResult(interp);
- Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue));
+ Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue);
Tcl_ResetResult(interp);
break;
case TCL_WIDE_INT:
- if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
- ckfree((char *)args);
+ if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
+ ckfree(args);
return TCL_ERROR;
}
valuePtr = Tcl_GetObjResult(interp);
- Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue));
+ Tcl_GetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
Tcl_ResetResult(interp);
break;
}
@@ -3231,8 +3547,8 @@ OldMathFuncProc(
*/
errno = 0;
- result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult);
- ckfree((char *)args);
+ result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult);
+ ckfree(args);
if (result != TCL_OK) {
return result;
}
@@ -3271,12 +3587,12 @@ OldMathFuncProc(
static void
OldMathFuncDeleteProc(
- ClientData clientData)
+ ClientData clientData)
{
OldMathFuncData *dataPtr = clientData;
- ckfree((void *) dataPtr->argTypes);
- ckfree((void *) dataPtr);
+ ckfree(dataPtr->argTypes);
+ ckfree(dataPtr);
}
/*
@@ -3336,6 +3652,7 @@ Tcl_GetMathFuncInfo(
Tcl_AppendToObj(message, name, -1);
Tcl_AppendToObj(message, "\"", 1);
Tcl_SetObjResult(interp, message);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
*numArgsPtr = -1;
*argTypesPtr = NULL;
*procPtr = NULL;
@@ -3449,9 +3766,6 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
-#if !defined(TCL_NO_STACK_CHECK)
- int localInt; /* used for checking the stack */
-#endif
register Interp *iPtr = (Interp *) interp;
/*
@@ -3466,7 +3780,7 @@ TclInterpReady(
*/
if (iPtr->flags & DELETED) {
- Tcl_ResetResult(interp);
+ /* JJM - Superfluous Tcl_ResetResult call removed. */
Tcl_AppendResult(interp,
"attempt to call eval in deleted interpreter", NULL);
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
@@ -3474,137 +3788,401 @@ TclInterpReady(
return TCL_ERROR;
}
+ if (iPtr->execEnvPtr->rewind) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make sure the script being evaluated (if any) has not been canceled.
+ */
+
+ if (TclCanceled(iPtr) &&
+ (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) {
+ return TCL_ERROR;
+ }
+
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large, it's
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)
- && CheckCStack(iPtr, &localInt)) {
+ if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
- if (!CheckCStack(iPtr, &localInt)) {
- Tcl_AppendResult(interp,
- "out of stack space (infinite loop?)", NULL);
- } else {
- Tcl_AppendResult(interp,
- "too many nested evaluations (infinite loop?)", NULL);
+ Tcl_AppendResult(interp,
+ "too many nested evaluations (infinite loop?)", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResetCancellation --
+ *
+ * Reset the script cancellation flags if the nesting level
+ * (iPtr->numLevels) for the interp is zero or argument force is
+ * non-zero.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The script cancellation flags for the interp may be reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclResetCancellation(
+ Tcl_Interp *interp,
+ int force)
+{
+ register Interp *iPtr = (Interp *) interp;
+
+ if (iPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (force || (iPtr->numLevels == 0)) {
+ TclUnsetCancelFlags(iPtr);
}
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Canceled --
+ *
+ * Check if the script in progress has been canceled, i.e.,
+ * Tcl_CancelEval was called for this interpreter or any of its master
+ * interpreters.
+ *
+ * Results:
+ * The return value is TCL_OK if the script evaluation has not been
+ * canceled, TCL_ERROR otherwise.
+ *
+ * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in
+ * the interpreter's result object. Otherwise, the interpreter's result
+ * object is left unchanged. If "flags" contains TCL_CANCEL_UNWIND,
+ * TCL_ERROR will only be returned if the script evaluation is being
+ * completely unwound.
+ *
+ * Side effects:
+ * The CANCELED flag for the interp will be reset if it is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Canceled(
+ Tcl_Interp *interp,
+ int flags)
+{
+ register Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Has the current script in progress for this interpreter been canceled
+ * or is the stack being unwound due to the previous script cancellation?
+ */
+
+ if (!TclCanceled(iPtr)) {
+ return TCL_OK;
+ }
+
+ /*
+ * The CANCELED flag is a one-shot flag that is reset immediately upon
+ * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
+ * continue to report that the script in progress has been canceled
+ * thereby allowing the evaluation stack for the interp to be fully
+ * unwound.
+ */
+
+ iPtr->flags &= ~CANCELED;
+
+ /*
+ * The CANCELED flag was detected and reset; however, if the caller
+ * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
+ * (indicating that the script in progress has been canceled) if the
+ * evaluation stack for the interp is being fully unwound.
+ */
+
+ if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
+ return TCL_OK;
+ }
+
+ /*
+ * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
+ * interp's result; otherwise, we leave it alone.
+ */
+
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ const char *id, *message = NULL;
+ int length;
+
+ /*
+ * Setup errorCode variables so that we can differentiate between
+ * being canceled and unwound.
+ */
+
+ if (iPtr->asyncCancelMsg != NULL) {
+ message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ } else {
+ length = 0;
+ }
+
+ if (iPtr->flags & TCL_CANCEL_UNWIND) {
+ id = "IUNWIND";
+ if (length == 0) {
+ message = "eval unwound";
+ }
+ } else {
+ id = "ICANCEL";
+ if (length == 0) {
+ message = "eval canceled";
+ }
+ }
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
+ }
+
+ /*
+ * Return TCL_ERROR to the caller (not necessarily just the Tcl core
+ * itself) that indicates further processing of the script or command in
+ * progress should halt gracefully and as soon as possible.
+ */
+
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * TclEvalObjvInternal
+ * Tcl_CancelEval --
*
- * This function evaluates a Tcl command that has already been parsed
- * into words, with one Tcl_Obj holding each word. The caller is
- * responsible for managing the iPtr->numLevels.
+ * This function schedules the cancellation of the current script in the
+ * given interpreter.
*
- * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode
- * engine also calls it directly.
+ * Results:
+ * The return value is a standard Tcl completion code such as TCL_OK or
+ * TCL_ERROR. Since the interp may belong to a different thread, no error
+ * message can be left in the interp's result.
+ *
+ * Side effects:
+ * The script in progress in the specified interpreter will be canceled
+ * with TCL_ERROR after asynchronous handlers are invoked at the next
+ * Tcl_Canceled check.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_CancelEval(
+ Tcl_Interp *interp, /* Interpreter in which to cancel the
+ * script. */
+ Tcl_Obj *resultObjPtr, /* The script cancellation error message or
+ * NULL for a default error message. */
+ ClientData clientData, /* Passed to CancelEvalProc. */
+ int flags) /* Collection of OR-ed bits that control
+ * the cancellation of the script. Only
+ * TCL_CANCEL_UNWIND is currently
+ * supported. */
+{
+ Tcl_HashEntry *hPtr;
+ CancelInfo *cancelInfo;
+ int code = TCL_ERROR;
+ const char *result;
+
+ if (interp == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized != 1) {
+ /*
+ * No CancelInfo hash table (Tcl_CreateInterp has never been called?)
+ */
+
+ goto done;
+ }
+ hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+ if (hPtr == NULL) {
+ /*
+ * No CancelInfo record for this interpreter.
+ */
+
+ goto done;
+ }
+ cancelInfo = Tcl_GetHashValue(hPtr);
+
+ /*
+ * Populate information needed by the interpreter thread to fulfill the
+ * cancellation request. Currently, clientData is ignored. If the
+ * TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
+ * allowed to catch the script cancellation because the evaluation stack
+ * for the interp is completely unwound.
+ */
+
+ if (resultObjPtr != NULL) {
+ result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
+ cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length);
+ memcpy(cancelInfo->result, result, (size_t) cancelInfo->length);
+ TclDecrRefCount(resultObjPtr); /* Discard their result object. */
+ } else {
+ cancelInfo->result = NULL;
+ cancelInfo->length = 0;
+ }
+ cancelInfo->clientData = clientData;
+ cancelInfo->flags = flags;
+ Tcl_AsyncMark(cancelInfo->async);
+ code = TCL_OK;
+
+ done:
+ Tcl_MutexUnlock(&cancelLock);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InterpActive --
+ *
+ * Returns non-zero if the specified interpreter is in use, i.e. if there
+ * is an evaluation currently active in the interpreter.
+ *
+ * Results:
+ * See above.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_InterpActive(
+ Tcl_Interp *interp)
+{
+ return ((Interp *) interp)->numLevels > 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObjv --
+ *
+ * This function evaluates a Tcl command that has already been parsed
+ * into words, with one Tcl_Obj holding each word.
*
* Results:
* The return value is a standard Tcl completion code such as TCL_OK or
- * TCL_ERROR. A result or error message is left in interp's result. If an
- * error occurs, this function does NOT add any information to the
- * errorInfo variable.
+ * TCL_ERROR. A result or error message is left in interp's result.
*
* Side effects:
- * Depends on the command.
+ * Always pushes a callback. Other side effects depend on the command.
*
*----------------------------------------------------------------------
*/
int
-TclEvalObjvInternal(
+Tcl_EvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
int objc, /* Number of words in command. */
Tcl_Obj *const objv[], /* An array of pointers to objects that are
* the words that make up the command. */
- const char *command, /* Points to the beginning of the string
- * representation of the command; this is used
- * for traces. NULL if the string
- * representation of the command is unknown is
- * to be generated from (objc,objv), -1 if it
- * is to be generated from bytecode
- * source. This is only needed the traces. */
- int length, /* Number of bytes in command; if -1, all
- * characters up to the first null byte are
- * used. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
- * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
- * currently supported. */
+ * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
+ * TCL_EVAL_NOERR are currently supported. */
+{
+ int result;
+ NRE_callback *rootPtr = TOP_CB(interp);
+
+ result = TclNREvalObjv(interp, objc, objv, flags, NULL);
+ return TclNRRunCallbacks(interp, result, rootPtr);
+}
+
+int
+TclNREvalObjv(
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the
+ * command. Also used for error reporting. */
+ int objc, /* Number of words in command. */
+ Tcl_Obj *const objv[], /* An array of pointers to objects that are
+ * the words that make up the command. */
+ int flags, /* Collection of OR-ed bits that control the
+ * evaluation of the script. Only
+ * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
+ * TCL_EVAL_NOERR are currently supported. */
+ Command *cmdPtr) /* NULL if the Command is to be looked up
+ * here, otherwise the pointer to the
+ * requested Command struct to be invoked. */
{
- Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
- Tcl_Obj **newObjv;
- int i;
- CallFrame *savedVarFramePtr = NULL;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- int code = TCL_OK;
- int traceCode = TCL_OK;
- int checkTraces = 1, traced;
- Namespace *savedNsPtr = NULL;
+ int result;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
- Tcl_Obj *commandPtr = NULL;
+ Command **cmdPtrPtr;
- if (TclInterpReady(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
- if (objc == 0) {
- return TCL_OK;
- }
+ iPtr->lookupNsPtr = NULL;
/*
- * If any execution traces rename or delete the current command, we may
- * need (at most) two passes here.
+ * 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.
*/
- reparseBecauseOfTraces:
+ if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
+ TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), NULL, NULL);
+ iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
+ } else {
+ 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;
+ }
/*
- * Configure evaluation context to match the requested flags.
+ * Push records for task to be done on return, in INVERSE order. First, if
+ * needed, the exception handlers (as they should happen last).
*/
- if (flags) {
- if (flags & TCL_EVAL_INVOKE) {
- savedNsPtr = varFramePtr->nsPtr;
- if (lookupNsPtr) {
- varFramePtr->nsPtr = lookupNsPtr;
- iPtr->lookupNsPtr = NULL;
- } else {
- varFramePtr->nsPtr = iPtr->globalNsPtr;
- }
- } else if ((flags & TCL_EVAL_GLOBAL)
- && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) {
- varFramePtr = iPtr->rootFramePtr;
- savedVarFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = varFramePtr;
- }
+ if (!(flags & TCL_EVAL_NOERR)) {
+ TEOV_PushExceptionHandlers(interp, objc, objv, flags);
}
/*
- * Find the function to execute this command. If there isn't one, then see
- * if there is an unknown command handler registered for this namespace.
- * If so, create a new word array with the handler as the first words and
- * the original command words as arguments. Then call ourselves
- * recursively to execute it.
+ * Configure evaluation context to match the requested flags.
*/
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
- if (!cmdPtr) {
- goto notFound;
- }
+ if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) {
+ if (!lookupNsPtr) {
+ lookupNsPtr = iPtr->globalNsPtr;
+ }
+ } else {
+ if (flags & TCL_EVAL_GLOBAL) {
+ TEOV_SwitchVarFrame(interp);
+ lookupNsPtr = iPtr->globalNsPtr;
+ }
- if (savedNsPtr) {
- varFramePtr->nsPtr = savedNsPtr;
- } else if (iPtr->ensembleRewrite.sourceObjs) {
/*
* TCL_EVAL_INVOKE was not set: clear rewrite rules
*/
@@ -3613,60 +4191,43 @@ TclEvalObjvInternal(
}
/*
- * Call trace functions if needed.
+ * Lookup the command
*/
- traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES));
- if (traced && checkTraces) {
- int cmdEpoch = cmdPtr->cmdEpoch;
- int newEpoch;
+ cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+ if (!cmdPtr) {
+ return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ }
- /*
- * Insure that we have a correct nul-terminated command string for the
- * trace code.
- */
+ iPtr->cmdCount++;
+ if (TclLimitExceeded(iPtr->limit)) {
+ return TCL_ERROR;
+ }
- commandPtr = GetCommandSource(iPtr, command, length, objc, objv);
- command = TclGetStringFromObj(commandPtr, &length);
+ /*
+ * Found a command! The real work begins now ...
+ */
+ commandFound:
+ if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
/*
- * 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.
+ * Call enter traces. They will schedule a call to the leave traces if
+ * necessary.
*/
- cmdPtr->refCount++;
- if (iPtr->tracePtr && (traceCode == TCL_OK)) {
- traceCode = TclCheckInterpTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
- }
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
- traceCode = TclCheckExecutionTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
+ result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr);
+ if (!cmdPtr) {
+ return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
}
- newEpoch = cmdPtr->cmdEpoch;
- TclCleanupCommandMacro(cmdPtr);
-
- /*
- * If the traces modified/deleted the command or any existing traces,
- * they will update the command's epoch. When that happens, set
- * checkTraces is set to 0 to prevent the re-calling of traces (and
- * any possible infinite loop) and we go back to re-find the command
- * implementation.
- */
-
- if (cmdEpoch != newEpoch) {
- checkTraces = 0;
- if (commandPtr) {
- Tcl_DecrRefCount(commandPtr);
- }
- goto reparseBecauseOfTraces;
+ if (result != TCL_OK) {
+ return result;
}
}
+
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
- char *a[10];
+ const char *a[10];
int i = 0;
while (i < 10) {
@@ -3677,172 +4238,341 @@ TclEvalObjvInternal(
}
if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
- char *a[4]; int i[2];
+ 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]);
+ 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()) {
+ TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL);
+ }
+ if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
+ TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
+ (Tcl_Obj **)(objv + 1));
+ }
#endif /* USE_DTRACE */
-
/*
- * Finally, invoke the command's Tcl_ObjCmdProc.
+ * 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++;
- iPtr->cmdCount++;
- if (code == TCL_OK && traceCode == TCL_OK
- && !TclLimitExceeded(iPtr->limit)) {
- if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
- TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
- (Tcl_Obj **)(objv + 1));
- }
- code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
- if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
- TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
- }
- }
-
- if (TclAsyncReady(iPtr)) {
- code = Tcl_AsyncInvoke(interp, code);
- }
- if (code == TCL_OK && TclLimitReady(iPtr->limit)) {
- code = Tcl_LimitCheck(interp);
- }
/*
- * Call 'leave' command traces
+ * Find the objProc to call: nreProc if available, objProc otherwise. Push
+ * a callback to do the actual running.
*/
- if (traced) {
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
- traceCode = TclCheckExecutionTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
- }
- if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
- traceCode = TclCheckInterpTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
- }
- }
-
- /*
- * If one of the trace invocation resulted in error, then change the
- * result code accordingly. Note, that the interp->result should
- * already be set correctly by the call to TraceExecutionProc.
- */
-
- if (traceCode != TCL_OK) {
- code = traceCode;
- }
- if (commandPtr) {
- Tcl_DecrRefCount(commandPtr);
- }
- }
+ if (cmdPtr->nreProc) {
+ TclNRAddCallback(interp, NRRunObjProc, cmdPtr,
+ INT2PTR(objc), (ClientData) objv, NULL);
+ return TCL_OK;
+ } else {
+ return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
+ }
+}
- /*
- * Decrement the reference count of cmdPtr and deallocate it if it has
- * dropped to zero.
- */
+void
+TclPushTailcallPoint(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ ((Interp *) interp)->numLevels++;
+}
- TclCleanupCommandMacro(cmdPtr);
+int
+TclNRRunCallbacks(
+ Tcl_Interp *interp,
+ int result,
+ struct NRE_callback *rootPtr)
+ /* All callbacks down to rootPtr not inclusive
+ * are to be run. */
+{
+ Interp *iPtr = (Interp *) interp;
+ NRE_callback *callbackPtr;
+ Tcl_NRPostProc *procPtr;
/*
* If the interpreter has a non-empty string result, the result object is
* either empty or stale because some function set interp->result
* directly. If so, move the string result to the result object, then
* reset the string result.
+ *
+ * This only needs to be done for the first item in the list: all other
+ * are for NR function calls, and those are Tcl_Obj based.
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
-#ifdef USE_DTRACE
- if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
- Tcl_Obj *r;
+ while (TOP_CB(interp) != rootPtr) {
+ callbackPtr = TOP_CB(interp);
+ procPtr = callbackPtr->procPtr;
+ TOP_CB(interp) = callbackPtr->nextPtr;
+ result = procPtr(callbackPtr->data, interp, result);
+ TCLNR_FREE(interp, callbackPtr);
+ }
+ return result;
+}
+
+int
+NRCommand(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr = data[0];
+ /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */
- r = Tcl_GetObjResult(interp);
- TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r);
+ if (cmdPtr) {
+ TclCleanupCommandMacro(cmdPtr);
}
-#endif /* USE_DTRACE */
+ ((Interp *)interp)->numLevels--;
- done:
- if (savedVarFramePtr) {
- iPtr->varFramePtr = savedVarFramePtr;
+ /* OPT ??
+ * Do not interrupt a series of cleanups with async or limit checks:
+ * just check at the end?
+ */
+
+ if (TclAsyncReady(iPtr)) {
+ result = Tcl_AsyncInvoke(interp, result);
+ }
+ if ((result == TCL_OK) && TclCanceled(iPtr)) {
+ result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
+ }
+ if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
+ result = Tcl_LimitCheck(interp);
}
- return code;
- notFound:
- {
- Namespace *currNsPtr = NULL; /* Used to check for and invoke any
- * registered unknown command handler
- * for the current namespace (TIP
- * 181). */
- int newObjc, handlerObjc;
- Tcl_Obj **handlerObjv;
-
- currNsPtr = varFramePtr->nsPtr;
- if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
- currNsPtr = iPtr->globalNsPtr;
- if (currNsPtr == NULL) {
- Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer");
- }
- }
+ return result;
+}
- /*
- * Check to see if the resolution namespace has lost its unknown
- * handler. If so, reset it to "::unknown".
- */
+static int
+NRRunObjProc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ /* OPT: do not call? */
- if (currNsPtr->unknownHandlerPtr == NULL) {
- TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
- Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
- }
+ Command* cmdPtr = data[0];
+ int objc = PTR2INT(data[1]);
+ Tcl_Obj **objv = data[2];
+ return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TEOV_Exception -
+ * TEOV_LookupCmdFromObj -
+ * TEOV_RunEnterTraces -
+ * TEOV_RunLeaveTraces -
+ * TEOV_NotFound -
+ *
+ * These are helper functions for Tcl_EvalObjv.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TEOV_PushExceptionHandlers(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * If any error processing is necessary, push the appropriate records.
+ * Note that we have to push them in the inverse order: first the one that
+ * has to run last.
+ */
+
+ if (!(flags & TCL_EVAL_INVOKE)) {
/*
- * Get the list of words for the unknown handler and allocate enough
- * space to hold both the handler prefix and all words of the command
- * invokation itself.
+ * Error messages
*/
- Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
- &handlerObjc, &handlerObjv);
- newObjc = objc + handlerObjc;
- newObjv = (Tcl_Obj **) TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * newObjc);
+ TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc),
+ (ClientData) objv, NULL, NULL);
+ }
+ if (iPtr->numLevels == 1) {
/*
- * Copy command prefix from unknown handler and add on the real
- * command's full argument list. Note that we only use memcpy() once
- * because we have to increment the reference count of all the handler
- * arguments anyway.
+ * No CONTINUE or BREAK at level 0, manage RETURN
*/
- for (i = 0; i < handlerObjc; ++i) {
- newObjv[i] = handlerObjv[i];
- Tcl_IncrRefCount(newObjv[i]);
+ TclNRAddCallback(interp, TEOV_Exception, INT2PTR(iPtr->evalFlags),
+ NULL, NULL, NULL);
+ }
+}
+
+static void
+TEOV_SwitchVarFrame(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Change the varFrame to be the rootVarFrame, and push a record to
+ * restore things at the end.
+ */
+
+ TclNRAddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL,
+ NULL, NULL);
+ iPtr->varFramePtr = iPtr->rootFramePtr;
+}
+
+static int
+TEOV_RestoreVarFrame(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ((Interp *) interp)->varFramePtr = data[0];
+ return result;
+}
+
+static int
+TEOV_Exception(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS);
+
+ if (result != TCL_OK) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
}
- memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
+ if ((result != TCL_ERROR) && !allowExceptions) {
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
+ }
+ }
+ /*
+ * We are returning to level 0, so should process TclResetCancellation. As
+ * numLevels has not *yet* been decreased, do not call it: do the thing
+ * here directly.
+ */
+
+ TclUnsetCancelFlags(iPtr);
+ return result;
+}
+
+static int
+TEOV_Error(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
+ const char *cmdString;
+ int cmdLen;
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj **objv = data[1];
+
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){
/*
- * Look up and invoke the handler (by recursive call to this
- * function). If there is no handler at all, instead of doing the
- * recursive call we just generate a generic error message; it would
- * be an infinite-recursion nightmare otherwise.
+ * If there was an error, a command string will be needed for the
+ * error log: get it out of the itemPtr. The details depend on the
+ * type.
*/
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
- if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[0]), "\"", NULL);
- code = TCL_ERROR;
- } else {
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, newObjc, newObjv, command,
- length, 0);
- iPtr->numLevels--;
+ listPtr = Tcl_NewListObj(objc, objv);
+ cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
+ Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
+ Tcl_DecrRefCount(listPtr);
+ }
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ return result;
+}
+
+static int
+TEOV_NotFound(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[],
+ Namespace *lookupNsPtr)
+{
+ Command * cmdPtr;
+ Interp *iPtr = (Interp *) interp;
+ int i, newObjc, handlerObjc;
+ Tcl_Obj **newObjv, **handlerObjv;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
+ * unknown command handler for the current
+ * namespace (TIP 181). */
+ Namespace *savedNsPtr = NULL;
+
+ currNsPtr = varFramePtr->nsPtr;
+ if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
+ currNsPtr = iPtr->globalNsPtr;
+ if (currNsPtr == NULL) {
+ Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer");
}
+ }
+
+ /*
+ * Check to see if the resolution namespace has lost its unknown handler.
+ * If so, reset it to "::unknown".
+ */
+
+ if (currNsPtr->unknownHandlerPtr == NULL) {
+ TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
+ Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
+ }
+
+ /*
+ * Get the list of words for the unknown handler and allocate enough space
+ * to hold both the handler prefix and all words of the command invokation
+ * itself.
+ */
+
+ Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
+ &handlerObjc, &handlerObjv);
+ newObjc = objc + handlerObjc;
+ newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc);
+
+ /*
+ * Copy command prefix from unknown handler and add on the real command's
+ * full argument list. Note that we only use memcpy() once because we have
+ * to increment the reference count of all the handler arguments anyway.
+ */
+
+ for (i = 0; i < handlerObjc; ++i) {
+ newObjv[i] = handlerObjv[i];
+ Tcl_IncrRefCount(newObjv[i]);
+ }
+ memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
+
+ /*
+ * Look up and invoke the handler (by recursive call to this function). If
+ * there is no handler at all, instead of doing the recursive call we just
+ * generate a generic error message; it would be an infinite-recursion
+ * nightmare otherwise.
+ *
+ * In this case we worry a bit less about recursion for now, and call the
+ * "blocking" interface.
+ */
+
+ cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
+ if (cmdPtr == NULL) {
+ Tcl_AppendResult(interp, "invalid command name \"",
+ TclGetString(objv[0]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
+ TclGetString(objv[0]), NULL);
/*
* Release any resources we locked and allocated during the handler
@@ -3853,89 +4583,174 @@ TclEvalObjvInternal(
Tcl_DecrRefCount(newObjv[i]);
}
TclStackFree(interp, newObjv);
- if (savedNsPtr) {
- varFramePtr->nsPtr = savedNsPtr;
- }
- goto done;
+ return TCL_ERROR;
+ }
+
+ if (lookupNsPtr) {
+ savedNsPtr = varFramePtr->nsPtr;
+ varFramePtr->nsPtr = lookupNsPtr;
}
+ TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
+ newObjv, savedNsPtr, NULL);
+ iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EvalObjv --
- *
- * This function evaluates a Tcl command that has already been parsed
- * into words, with one Tcl_Obj holding each word.
- *
- * Results:
- * The return value is a standard Tcl completion code such as TCL_OK or
- * TCL_ERROR. A result or error message is left in interp's result.
- *
- * Side effects:
- * Depends on the command.
- *
- *----------------------------------------------------------------------
- */
-int
-Tcl_EvalObjv(
- Tcl_Interp *interp, /* Interpreter in which to evaluate the
- * command. Also used for error reporting. */
- int objc, /* Number of words in command. */
- Tcl_Obj *const objv[], /* An array of pointers to objects that are
- * the words that make up the command. */
- int flags) /* Collection of OR-ed bits that control the
- * evaluation of the script. Only
- * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
- * currently supported. */
+static int
+TEOV_NotFoundCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
{
Interp *iPtr = (Interp *) interp;
- int code = TCL_OK;
- int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj **objv = data[1];
+ Namespace *savedNsPtr = data[2];
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags);
- iPtr->numLevels--;
+ int i;
- if (code == TCL_OK) {
- return code;
- } else {
+ if (savedNsPtr) {
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ }
+
+ /*
+ * Release any resources we locked and allocated during the handler call.
+ */
+
+ for (i = 0; i < objc; ++i) {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ TclStackFree(interp, objv);
+
+ return result;
+}
+static int
+TEOV_RunEnterTraces(
+ Tcl_Interp *interp,
+ Command **cmdPtrPtr,
+ int objc,
+ Tcl_Obj *const objv[],
+ Namespace *lookupNsPtr)
+{
+ 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);
+
+ /*
+ * 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.
+ */
+
+ cmdPtr->refCount++;
+ if (iPtr->tracePtr) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
+ traceCode = TclCheckExecutionTraces(interp, command, length,
+ cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ 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 (cmdPtr) {
/*
- * If we are again at the top level, process any unusual return code
- * returned by the evaluated code.
+ * Command was found: push a record to schedule the leave traces.
*/
- if (iPtr->numLevels == 0) {
- if (code == TCL_RETURN) {
- code = TclUpdateReturnInfo(iPtr);
- }
- if ((code != TCL_ERROR) && !allowExceptions) {
- ProcessUnexpectedResult(interp, code);
- code = TCL_ERROR;
- }
- }
+ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode),
+ commandPtr, cmdPtr, NULL);
+ cmdPtr->refCount++;
+ } else {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ return traceCode;
+}
- if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
- /*
- * If there was an error, a command string will be needed for the
- * error log: generate it now. Do not worry too much about doing
- * it expensively.
- */
+static int
+TEOV_RunLeaveTraces(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ const char *command;
+ int length, objc;
+ Tcl_Obj **objv;
+ int traceCode = PTR2INT(data[0]);
+ Tcl_Obj *commandPtr = data[1];
+ Command *cmdPtr = data[2];
- Tcl_Obj *listPtr;
- char *cmdString;
- int cmdLen;
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+ if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) {
+ Tcl_Panic("Who messed with commandPtr?");
+ }
- listPtr = Tcl_NewListObj(objc, objv);
- cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
- Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
- Tcl_DecrRefCount(listPtr);
+ if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
+ traceCode = TclCheckExecutionTraces(interp, command, length,
+ cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
+ if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
+ }
+ }
+ Tcl_DecrRefCount(commandPtr);
- return code;
+ /*
+ * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels.
+ * Prevent that by resetting the cmdPtr field and dealing right here with
+ * cmdPtr->refCount.
+ */
+
+ TclCleanupCommandMacro(cmdPtr);
+
+ if (traceCode != TCL_OK) {
+ return traceCode;
}
+ return result;
+}
+
+static inline Command *
+TEOV_LookupCmdFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *namePtr,
+ Namespace *lookupNsPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr;
+ Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;
+
+ if (lookupNsPtr) {
+ iPtr->varFramePtr->nsPtr = lookupNsPtr;
+ iPtr->lookupNsPtr = NULL;
+ }
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ return cmdPtr;
}
/*
@@ -3969,7 +4784,7 @@ Tcl_EvalTokensStandard(
* Must be at least 1. */
{
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
- NULL, NULL);
+ NULL, NULL);
}
/*
@@ -4053,7 +4868,7 @@ Tcl_EvalEx(
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
{
- return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
+ return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}
int
@@ -4068,23 +4883,23 @@ TclEvalEx(
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
int line, /* The line the script starts on. */
- int* clNextOuter, /* Information about an outer context for */
- CONST char* outerScript) /* continuation line data. This is set only in
- * TclSubstTokens(), to properly handle
- * [...]-nested commands. The 'outerScript'
- * refers to the most-outer script containing the
- * embedded command, which is refered to by
- * 'script'. The 'clNextOuter' refers to the
- * current entry in the table of continuation
- * lines in this "master script", and the
- * character offsets are relative to the
- * 'outerScript' as well.
- *
- * If outerScript == script, then this call is
- * for the outer-most script/command. See
- * Tcl_EvalEx() and TclEvalObjEx() for places
- * generating arguments for which this is true.
- */
+ int *clNextOuter, /* Information about an outer context for */
+ const char *outerScript) /* continuation line data. This is set only in
+ * TclSubstTokens(), to properly handle
+ * [...]-nested commands. The 'outerScript'
+ * refers to the most-outer script containing
+ * the embedded command, which is refered to
+ * by 'script'. The 'clNextOuter' refers to
+ * the current entry in the table of
+ * continuation lines in this "master script",
+ * and the character offsets are relative to
+ * the 'outerScript' as well.
+ *
+ * If outerScript == script, then this call is
+ * for the outer-most script/command. See
+ * Tcl_EvalEx() and TclEvalObjEx() for places
+ * generating arguments for which this is
+ * true. */
{
Interp *iPtr = (Interp *) interp;
const char *p, *next;
@@ -4102,25 +4917,21 @@ TclEvalEx(
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
- Tcl_Parse *parsePtr = (Tcl_Parse *)
- TclStackAlloc(interp, sizeof(Tcl_Parse));
- CmdFrame *eeFramePtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
- Tcl_Obj **stackObjArray = (Tcl_Obj **)
+ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ Tcl_Obj **stackObjArray =
TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
- int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int));
- int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int));
+ int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int));
+ int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int));
/* TIP #280 Structures for tracking of command
* locations. */
- /*
- * Pointer for the tracking of invisible continuation lines. Initialized
- * only if the caller gave us a table of locations to track, via
- * scriptCLLocPtr. It always refers to the table entry holding the
- * location of the next invisible continuation line to look for, while
- * parsing the script.
- */
-
- int* clNext = NULL;
+ int *clNext = NULL; /* Pointer for the tracking of invisible
+ * continuation lines. Initialized only if the
+ * caller gave us a table of locations to
+ * track, via scriptCLLocPtr. It always refers
+ * to the table entry holding the location of
+ * the next invisible continuation line to
+ * look for, while parsing the script. */
if (iPtr->scriptCLLocPtr) {
if (clNextOuter) {
@@ -4162,6 +4973,14 @@ TclEvalEx(
* 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;
+
+ iPtr->cmdFramePtr = eeFramePtr;
if (iPtr->evalFlags & TCL_EVAL_CTX) {
/*
* Path information comes out of the context.
@@ -4191,6 +5010,7 @@ TclEvalEx(
/*
* Error message in the interp result.
*/
+
code = TCL_ERROR;
goto error;
}
@@ -4208,12 +5028,6 @@ TclEvalEx(
eeFramePtr->data.eval.path = NULL;
}
- eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1;
- eeFramePtr->framePtr = iPtr->framePtr;
- eeFramePtr->nextPtr = iPtr->cmdFramePtr;
- eeFramePtr->nline = 0;
- eeFramePtr->line = NULL;
-
iPtr->evalFlags = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
@@ -4228,8 +5042,8 @@ TclEvalEx(
*/
TclAdvanceLines(&line, p, parsePtr->commandStart);
- TclAdvanceContinuations (&line, &clNext,
- parsePtr->commandStart - outerScript);
+ TclAdvanceContinuations(&line, &clNext,
+ parsePtr->commandStart - outerScript);
gotParse = 1;
if (parsePtr->numWords > 0) {
@@ -4240,27 +5054,26 @@ TclEvalEx(
* per-command parsing.
*/
- int wordLine = line;
+ int wordLine = line;
const char *wordStart = parsePtr->commandStart;
- int* wordCLNext = clNext;
+ int *wordCLNext = clNext;
+ unsigned int objectsNeeded = 0;
+ unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
- unsigned int objectsNeeded = 0;
- unsigned int numWords = parsePtr->numWords;
-
if (numWords > minObjs) {
- expand = (int *) ckalloc(numWords * sizeof(int));
- objvSpace = (Tcl_Obj **)
- ckalloc(numWords * sizeof(Tcl_Obj *));
- lineSpace = (int *) ckalloc(numWords * sizeof(int));
+ expand = ckalloc(numWords * sizeof(int));
+ objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *));
+ lineSpace = ckalloc(numWords * sizeof(int));
}
expandRequested = 0;
objv = objvSpace;
lines = lineSpace;
+ iPtr->cmdFramePtr = eeFramePtr->nextPtr;
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
objectsUsed < numWords;
objectsUsed++, tokenPtr += tokenPtr->numComponents+1) {
@@ -4273,8 +5086,8 @@ TclEvalEx(
*/
TclAdvanceLines(&wordLine, wordStart, tokenPtr->start);
- TclAdvanceContinuations (&wordLine, &wordCLNext,
- tokenPtr->start - outerScript);
+ TclAdvanceContinuations(&wordLine, &wordCLNext,
+ tokenPtr->start - outerScript);
wordStart = tokenPtr->start;
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
@@ -4286,12 +5099,12 @@ TclEvalEx(
code = TclSubstTokens(interp, tokenPtr+1,
tokenPtr->numComponents, NULL, wordLine,
- wordCLNext, outerScript);
+ wordCLNext, outerScript);
iPtr->evalFlags = 0;
if (code != TCL_OK) {
- goto error;
+ break;
}
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
@@ -4308,7 +5121,7 @@ TclEvalEx(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (expanding word %d)", objectsUsed));
Tcl_DecrRefCount(objv[objectsUsed]);
- goto error;
+ break;
}
expandRequested = 1;
expand[objectsUsed] = 1;
@@ -4320,10 +5133,14 @@ TclEvalEx(
}
if (wordCLNext) {
- TclContinuationsEnterDerived (objv[objectsUsed],
- wordStart - outerScript, wordCLNext);
+ TclContinuationsEnterDerived(objv[objectsUsed],
+ wordStart - outerScript, wordCLNext);
}
} /* for loop */
+ iPtr->cmdFramePtr = eeFramePtr;
+ if (code != TCL_OK) {
+ goto error;
+ }
if (expandRequested) {
/*
* Some word expansion was requested. Check for objv resize.
@@ -4334,11 +5151,10 @@ TclEvalEx(
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
- if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
- objv = objvSpace = (Tcl_Obj **)
+ if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
+ objv = objvSpace =
ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
- lines = lineSpace = (int *)
- ckalloc(objectsNeeded * sizeof(int));
+ lines = lineSpace = ckalloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
@@ -4365,10 +5181,10 @@ TclEvalEx(
objv += objIdx+1;
if (copy != stackObjArray) {
- ckfree((char *) copy);
+ ckfree(copy);
}
if (lcopy != linesStack) {
- ckfree((char *) lcopy);
+ ckfree(lcopy);
}
}
@@ -4393,14 +5209,9 @@ TclEvalEx(
eeFramePtr->nline = objectsUsed;
eeFramePtr->line = lines;
- TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr);
- iPtr->cmdFramePtr = eeFramePtr;
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, objectsUsed, objv,
- parsePtr->commandStart, parsePtr->commandSize, 0);
- iPtr->numLevels--;
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
- TclArgumentRelease (interp, objv, objectsUsed);
+ TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr);
+ code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR);
+ TclArgumentRelease(interp, objv, objectsUsed);
eeFramePtr->line = NULL;
eeFramePtr->nline = 0;
@@ -4413,9 +5224,9 @@ TclEvalEx(
}
objectsUsed = 0;
if (objvSpace != stackObjArray) {
- ckfree((char *) objvSpace);
+ ckfree(objvSpace);
objvSpace = stackObjArray;
- ckfree((char *) lineSpace);
+ ckfree(lineSpace);
lineSpace = linesStack;
}
@@ -4425,7 +5236,7 @@ TclEvalEx(
*/
if (expand != expandStack) {
- ckfree((char *) expand);
+ ckfree(expand);
expand = expandStack;
}
}
@@ -4490,11 +5301,11 @@ TclEvalEx(
Tcl_FreeParse(parsePtr);
}
if (objvSpace != stackObjArray) {
- ckfree((char *) objvSpace);
- ckfree((char *) lineSpace);
+ ckfree(objvSpace);
+ ckfree(lineSpace);
}
if (expand != expandStack) {
- ckfree((char *) expand);
+ ckfree(expand);
}
iPtr->varFramePtr = savedVarFramePtr;
@@ -4503,6 +5314,7 @@ TclEvalEx(
* TIP #280. Release the local CmdFrame, and its contents.
*/
+ iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eeFramePtr->data.eval.path);
}
@@ -4569,29 +5381,31 @@ TclAdvanceLines(
*/
void
-TclAdvanceContinuations (line,clNextPtrPtr,loc)
- int* line;
- int** clNextPtrPtr;
- int loc;
+TclAdvanceContinuations(
+ int *line,
+ int **clNextPtrPtr,
+ int loc)
{
/*
- * Track the invisible continuation lines embedded in a script, if
- * any. Here they are just spaces (already). They were removed by
- * TclSubstTokens() via TclParseBackslash().
+ * Track the invisible continuation lines embedded in a script, if any.
+ * Here they are just spaces (already). They were removed by
+ * TclSubstTokens via TclParseBackslash.
*
* *clNextPtrPtr <=> We have continuation lines to track.
* **clNextPtrPtr >= 0 <=> We are not beyond the last possible location.
* loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line.
*/
- while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) {
+ while (*clNextPtrPtr && (**clNextPtrPtr >= 0)
+ && (loc >= **clNextPtrPtr)) {
/*
* We just stepped over an invisible continuation line. Adjust the
* line counter and step to the table entry holding the location of
* the next continuation line to track.
*/
- (*line) ++;
- (*clNextPtrPtr) ++;
+
+ (*line)++;
+ (*clNextPtrPtr)++;
}
}
@@ -4609,8 +5423,8 @@ TclAdvanceContinuations (line,clNextPtrPtr,loc)
*
* TclArgumentEnter --
*
- * This procedure is a helper for the TIP #280 uplevel extension.
- * It enters location references for the arguments of a command to be
+ * This procedure is a helper for the TIP #280 uplevel extension. It
+ * enters location references for the arguments of a command to be
* invoked. Only the first entry has the actual data, further entries
* simply count the usage up.
*
@@ -4625,45 +5439,49 @@ TclAdvanceContinuations (line,clNextPtrPtr,loc)
*/
void
-TclArgumentEnter(interp,objv,objc,cfPtr)
- Tcl_Interp* interp;
- Tcl_Obj** objv;
- int objc;
- CmdFrame* cfPtr;
+TclArgumentEnter(
+ Tcl_Interp *interp,
+ Tcl_Obj **objv,
+ int objc,
+ CmdFrame *cfPtr)
{
- Interp* iPtr = (Interp*) interp;
+ Interp *iPtr = (Interp *) interp;
int new, i;
- Tcl_HashEntry* hPtr;
- CFWord* cfwPtr;
+ Tcl_HashEntry *hPtr;
+ CFWord *cfwPtr;
- for (i=1; i < objc; i++) {
+ for (i = 1; i < objc; i++) {
/*
- * Ignore argument words without line information (= dynamic). If
- * they are variables they may have location information associated
- * with that, either through globally recorded 'set' invokations, or
+ * Ignore argument words without line information (= dynamic). If they
+ * are variables they may have location information associated with
+ * that, either through globally recorded 'set' invokations, or
* literals in bytecode. Eitehr way there is no need to record
* something here.
*/
- if (cfPtr->line [i] < 0) continue;
- hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new);
+ if (cfPtr->line[i] < 0) {
+ continue;
+ }
+ hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new);
if (new) {
- /*
- * The word is not on the stack yet, remember the current location
- * and initialize references.
- */
- cfwPtr = (CFWord*) ckalloc (sizeof (CFWord));
- cfwPtr->framePtr = cfPtr;
- cfwPtr->word = i;
- cfwPtr->refCount = 1;
- Tcl_SetHashValue (hPtr, cfwPtr);
+ /*
+ * The word is not on the stack yet, remember the current location
+ * and initialize references.
+ */
+
+ cfwPtr = ckalloc(sizeof(CFWord));
+ cfwPtr->framePtr = cfPtr;
+ cfwPtr->word = i;
+ cfwPtr->refCount = 1;
+ Tcl_SetHashValue(hPtr, cfwPtr);
} else {
- /*
- * The word is already on the stack, its current location is not
- * relevant. Just remember the reference to prevent early removal.
- */
- cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
- cfwPtr->refCount ++;
+ /*
+ * The word is already on the stack, its current location is not
+ * relevant. Just remember the reference to prevent early removal.
+ */
+
+ cfwPtr = Tcl_GetHashValue(hPtr);
+ cfwPtr->refCount++;
}
}
}
@@ -4673,10 +5491,10 @@ TclArgumentEnter(interp,objv,objc,cfPtr)
*
* TclArgumentRelease --
*
- * This procedure is a helper for the TIP #280 uplevel extension.
- * It removes the location references for the arguments of a command
- * just done. Usage is counted down, the data is removed only when
- * no user is left over.
+ * This procedure is a helper for the TIP #280 uplevel extension. It
+ * removes the location references for the arguments of a command just
+ * done. Usage is counted down, the data is removed only when no user is
+ * left over.
*
* Results:
* None.
@@ -4689,27 +5507,31 @@ TclArgumentEnter(interp,objv,objc,cfPtr)
*/
void
-TclArgumentRelease(interp,objv,objc)
- Tcl_Interp* interp;
- Tcl_Obj** objv;
- int objc;
-{
- Interp* iPtr = (Interp*) interp;
- Tcl_HashEntry* hPtr;
- CFWord* cfwPtr;
+TclArgumentRelease(
+ Tcl_Interp *interp,
+ Tcl_Obj **objv,
+ int objc)
+{
+ Interp *iPtr = (Interp *) interp;
int i;
- for (i=1; i < objc; i++) {
- hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]);
+ for (i = 1; i < objc; i++) {
+ CFWord *cfwPtr;
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
- if (!hPtr) { continue; }
- cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
+ if (!hPtr) {
+ continue;
+ }
+ cfwPtr = Tcl_GetHashValue(hPtr);
- cfwPtr->refCount --;
- if (cfwPtr->refCount > 0) { continue; }
+ cfwPtr->refCount--;
+ if (cfwPtr->refCount > 0) {
+ continue;
+ }
- ckfree ((char*) cfwPtr);
- Tcl_DeleteHashEntry (hPtr);
+ ckfree(cfwPtr);
+ Tcl_DeleteHashEntry(hPtr);
}
}
@@ -4718,9 +5540,9 @@ TclArgumentRelease(interp,objv,objc)
*
* TclArgumentBCEnter --
*
- * This procedure is a helper for the TIP #280 uplevel extension.
- * It enters location references for the literal arguments of commands
- * in bytecode about to be invoked. Only the first entry has the actual
+ * This procedure is a helper for the TIP #280 uplevel extension. It
+ * enters location references for the literal arguments of commands in
+ * bytecode about to be invoked. Only the first entry has the actual
* data, further entries simply count the usage up.
*
* Results:
@@ -4734,68 +5556,77 @@ TclArgumentRelease(interp,objv,objc)
*/
void
-TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc)
- Tcl_Interp* interp;
- Tcl_Obj* objv[];
- int objc;
- void* codePtr;
- CmdFrame* cfPtr;
- int pc;
+TclArgumentBCEnter(
+ Tcl_Interp *interp,
+ Tcl_Obj *objv[],
+ int objc,
+ void *codePtr,
+ CmdFrame *cfPtr,
+ int pc)
{
- Interp* iPtr = (Interp*) interp;
- Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
+ 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) {
- ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
- hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc));
+ int word;
+ int cmd = PTR2INT(Tcl_GetHashValue(hePtr));
+ ECL *ePtr = &eclPtr->loc[cmd];
+ CFWordBC *lastPtr = NULL;
- if (hePtr) {
- int cmd = PTR2INT(Tcl_GetHashValue(hePtr));
- ECL* ePtr = &eclPtr->loc[cmd];
- int word;
-
- /*
- * 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,
- (char*) objv[word], &isnew);
- CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));
+ /*
+ * 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.
+ */
- cfwPtr->framePtr = cfPtr;
- cfwPtr->pc = pc;
- cfwPtr->word = word;
+ 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);
+ }
- 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 = (CFWordBC*) Tcl_GetHashValue(hPtr);
- }
+ Tcl_SetHashValue(hPtr, cfwPtr);
+ }
+ } /* for */
- Tcl_SetHashValue (hPtr, cfwPtr);
- }
- } /* for */
- } /* if */
+ cfPtr->litarg = lastPtr;
} /* if */
}
@@ -4804,10 +5635,10 @@ TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc)
*
* TclArgumentBCRelease --
*
- * This procedure is a helper for the TIP #280 uplevel extension.
- * It removes the location references for the literal arguments of
- * commands in bytecode just done. Usage is counted down, the data
- * is removed only when no user is left over.
+ * This procedure is a helper for the TIP #280 uplevel extension. It
+ * removes the location references for the literal arguments of commands
+ * in bytecode just done. Usage is counted down, the data is removed only
+ * when no user is left over.
*
* Results:
* None.
@@ -4820,48 +5651,34 @@ TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc)
*/
void
-TclArgumentBCRelease(interp,objv,objc,codePtr,pc)
- Tcl_Interp* interp;
- Tcl_Obj* objv[];
- int objc;
- void* codePtr;
- int pc;
+TclArgumentBCRelease(
+ Tcl_Interp *interp,
+ CmdFrame *cfPtr)
{
- Interp* iPtr = (Interp*) interp;
- Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
-
- if (hePtr) {
- ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
- hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc));
+ Interp *iPtr = (Interp *) interp;
+ CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
- if (hePtr) {
- int cmd = PTR2INT(Tcl_GetHashValue(hePtr));
- ECL* ePtr = &eclPtr->loc[cmd];
- int word;
+ while (cfwPtr) {
+ CFWordBC *nextPtr = cfwPtr->nextPtr;
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ CFWordBC *xPtr = Tcl_GetHashValue(hPtr);
- /*
- * Iterate in reverse order, to properly match our pop to the push
- * in TclArgumentBCEnter().
- */
- for (word = objc-1; word >= 1; word--) {
- if (ePtr->line[word] >= 0) {
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr,
- (char *) objv[word]);
- if (hPtr) {
- CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
-
- if (cfwPtr->prevPtr) {
- Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
- } else {
- Tcl_DeleteHashEntry(hPtr);
- }
+ if (xPtr != cfwPtr) {
+ Tcl_Panic("TclArgumentBC Enter/Release Mismatch");
+ }
- ckfree((char *) cfwPtr);
- }
- }
- }
+ if (cfwPtr->prevPtr) {
+ Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
+ } else {
+ Tcl_DeleteHashEntry(hPtr);
}
+
+ ckfree(cfwPtr);
+ cfwPtr = nextPtr;
}
+
+ cfPtr->litarg = NULL;
}
/*
@@ -4869,8 +5686,8 @@ TclArgumentBCRelease(interp,objv,objc,codePtr,pc)
*
* TclArgumentGet --
*
- * This procedure is a helper for the TIP #280 uplevel extension.
- * It find the location references for a Tcl_Obj, if any.
+ * This procedure is a helper for the TIP #280 uplevel extension. It
+ * finds the location references for a Tcl_Obj, if any.
*
* Results:
* None.
@@ -4883,15 +5700,15 @@ TclArgumentBCRelease(interp,objv,objc,codePtr,pc)
*/
void
-TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
- Tcl_Interp* interp;
- Tcl_Obj* obj;
- CmdFrame** cfPtrPtr;
- int* wordPtr;
+TclArgumentGet(
+ Tcl_Interp *interp,
+ Tcl_Obj *obj,
+ CmdFrame **cfPtrPtr,
+ int *wordPtr)
{
- Interp* iPtr = (Interp*) interp;
- Tcl_HashEntry* hPtr;
- CmdFrame* framePtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ CmdFrame *framePtr;
/*
* An object which either has no string rep or else is a canonical list is
@@ -4909,10 +5726,11 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
* stack. That is nearest.
*/
- hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
- CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
- *wordPtr = cfwPtr->word;
+ CFWord *cfwPtr = Tcl_GetHashValue(hPtr);
+
+ *wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
return;
}
@@ -4922,16 +5740,15 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
* that stack.
*/
- hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
-
+ hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
- CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
+ CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr);
framePtr = cfwPtr->framePtr;
- framePtr->data.tebc.pc = (char *) (((ByteCode*)
+ framePtr->data.tebc.pc = (char *) (((ByteCode *)
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
*cfPtrPtr = cfwPtr->framePtr;
- *wordPtr = cfwPtr->word;
+ *wordPtr = cfwPtr->word;
return;
}
}
@@ -5001,7 +5818,6 @@ Tcl_EvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
-
#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(
@@ -5059,80 +5875,146 @@ TclEvalObjEx(
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
- register Interp *iPtr = (Interp *) interp;
- char *script;
- int numSrcBytes;
- int result;
- CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
- * TCL_EVAL_GLOBAL was set. */
+ int result = TCL_OK;
+ NRE_callback *rootPtr = TOP_CB(interp);
- Tcl_IncrRefCount(objPtr);
+ result = TclNREvalObjEx(interp, objPtr, flags, invoker, word);
+ return TclNRRunCallbacks(interp, result, rootPtr);
+}
- /* Pure List Optimization (no string representation). 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 string and back out again.
- *
- * 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).
+int
+TclNREvalObjEx(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * a previous call to Tcl_CreateInterp). */
+ register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ * execute. */
+ int flags, /* Collection of OR-ed bits that control the
+ * evaluation of the script. Supported values
+ * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
+ const CmdFrame *invoker, /* Frame of the command doing the eval. */
+ int word) /* Index of the word which is in objPtr. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int result;
+
+ /*
+ * This function consists of three independent blocks for: direct
+ * evaluation of canonical lists, compileation and bytecode execution and
+ * finally direct evaluation. Precisely one of these blocks will be run.
*/
if (TclListObjIsCanonical(objPtr)) {
+ Tcl_Obj *listPtr = objPtr;
+ CmdFrame *eoFramePtr = NULL;
+ int objc;
+ Tcl_Obj **objv;
+
/*
- * TIP #280 Structures for tracking lines. As we know that this is
- * dynamic execution we ignore the invoker, even if known.
+ * Pure List Optimization (no string representation). 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
+ * string and back out again.
+ *
+ * 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).
*/
- int nelements;
- Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
- CmdFrame *eoFramePtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
+ /*
+ * Shimmer protection! Always pass an unshared obj. The caller could
+ * incr the refCount of objPtr AFTER calling us! To be completely safe
+ * we always make a copy. The callback takes care od the refCounts for
+ * both listPtr and objPtr.
+ *
+ * FIXME OPT: preserve just the internal rep?
+ */
- eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
- eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1
- : iPtr->cmdFramePtr->level + 1);
- eoFramePtr->framePtr = iPtr->framePtr;
- eoFramePtr->nextPtr = iPtr->cmdFramePtr;
+ Tcl_IncrRefCount(objPtr);
+ listPtr = TclListObjCopy(interp, objPtr);
+ Tcl_IncrRefCount(listPtr);
+ TclDecrRefCount(objPtr);
- eoFramePtr->nline = 0;
- eoFramePtr->line = NULL;
+ if (word != INT_MIN) {
+ /*
+ * TIP #280 Structures for tracking lines. As we know that this is
+ * dynamic execution we ignore the invoker, even if known.
+ *
+ * TIP #280. We do _not_ compute all the line numbers for the
+ * words in the command. For the eval of a pure list the most
+ * sensible choice is to put all words on line 1. Given that we
+ * neither need memory for them nor compute anything. 'line' is
+ * left NULL. The two places using this information (TclInfoFrame,
+ * and TclInitCompileEnv), are special-cased to use the proper
+ * line number directly instead of accessing the 'line' array.
+ *
+ * Note that we use (word==INTMIN) to signal that no command frame
+ * should be pushed, as needed by alias and ensemble redirections.
+ */
- eoFramePtr->cmd.listPtr = objPtr;
- Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
- eoFramePtr->data.eval.path = NULL;
+ eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ eoFramePtr->nline = 0;
+ eoFramePtr->line = NULL;
- /*
- * TIP #280 We do _not_ compute all the line numbers for the words
- * in the command. For the eval of a pure list the most sensible
- * choice is to put all words on line 1. Given that we neither
- * need memory for them nor compute anything. 'line' is left
- * NULL. The two places using this information (TclInfoFrame, and
- * TclInitCompileEnv), are special-cased to use the proper line
- * number directly instead of accessing the 'line' array.
- */
+ eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
+ eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
+ 1 : iPtr->cmdFramePtr->level + 1);
+ eoFramePtr->numLevels = iPtr->numLevels;
+ eoFramePtr->framePtr = iPtr->framePtr;
+ eoFramePtr->nextPtr = iPtr->cmdFramePtr;
- Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements);
+ eoFramePtr->cmd.listPtr = listPtr;
+ eoFramePtr->data.eval.path = NULL;
- iPtr->cmdFramePtr = eoFramePtr;
- result = Tcl_EvalObjv(interp, nelements, elements, flags);
+ iPtr->cmdFramePtr = eoFramePtr;
+ }
- Tcl_DecrRefCount(copyPtr);
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
- Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
- TclStackFree(interp, eoFramePtr);
- } else if (flags & TCL_EVAL_DIRECT) {
+ TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+ NULL, NULL);
+
+ ListObjGetElements(listPtr, objc, objv);
+ return TclNREvalObjv(interp, objc, objv, flags, NULL);
+ }
+
+ if (!(flags & TCL_EVAL_DIRECT)) {
/*
- * We're not supposed to use the compiler or byte-code interpreter.
- * Let Tcl_EvalEx evaluate the command directly (and probably more
- * slowly).
+ * Let the compiler/engine subsystem do the evaluation.
+ *
+ * TIP #280 The invoker provides us with the context for the script.
+ * We transfer this to the byte code compiler.
*/
+ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+ ByteCode *codePtr;
+ CallFrame *savedVarFramePtr = NULL; /* Saves old copy of
+ * iPtr->varFramePtr in case
+ * TCL_EVAL_GLOBAL was set. */
+
+ if (TclInterpReady(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (flags & TCL_EVAL_GLOBAL) {
+ savedVarFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = iPtr->rootFramePtr;
+ }
+ Tcl_IncrRefCount(objPtr);
+ codePtr = TclCompileObj(interp, objPtr, invoker, word);
+
+ TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
+ objPtr, INT2PTR(allowExceptions), NULL);
+ return TclNRExecuteByteCode(interp, codePtr);
+ }
+
+ {
/*
+ * 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
@@ -5142,6 +6024,9 @@ TclEvalObjEx(
* in the bytecode compiler.
*/
+ const char *script;
+ int numSrcBytes;
+
/*
* Now we check if we have data about invisible continuation lines for
* the script, and make it available to the direct script parser and
@@ -5151,7 +6036,7 @@ TclEvalObjEx(
* evaluator is using it, leading to the release of the associated
* ContLineLoc structure as well. To ensure that the latter doesn't
* happen we set a lock on it. We release this lock later in this
- * function, after the evaluator is done. The relevant "lineCLPtr"
+ * function, after the evaluator is done. The relevant "lineCLPtr"
* hashtable is managed in the file "tclObj.c".
*
* Another important action is to save (and later restore) the
@@ -5159,16 +6044,17 @@ TclEvalObjEx(
* executing nested commands in the eval/direct path.
*/
- ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr;
- ContLineLoc* clLocPtr = TclContinuationsGet (objPtr);
+ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr;
+ ContLineLoc *clLocPtr = TclContinuationsGet(objPtr);
if (clLocPtr) {
iPtr->scriptCLLocPtr = clLocPtr;
- Tcl_Preserve (iPtr->scriptCLLocPtr);
+ Tcl_Preserve(iPtr->scriptCLLocPtr);
} else {
iPtr->scriptCLLocPtr = NULL;
}
+ Tcl_IncrRefCount(objPtr);
if (invoker == NULL) {
/*
* No context, force opening of our own.
@@ -5191,8 +6077,7 @@ TclEvalObjEx(
*/
int pc = 0;
- CmdFrame *ctxPtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
@@ -5207,16 +6092,14 @@ TclEvalObjEx(
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- if ((ctxPtr->nline <= word) ||
- (ctxPtr->line[word] < 0) ||
- (ctxPtr->type != TCL_LOCATION_SOURCE)) {
+ if ((invoker->nline <= word) ||
+ (invoker->line[word] < 0) ||
+ (ctxPtr->type != TCL_LOCATION_SOURCE)) {
/*
- * Dynamic script, or dynamic context, force our own
- * context.
+ * Dynamic script, or dynamic context, force our own context.
*/
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
-
} else {
/*
* Absolute context to reuse.
@@ -5226,9 +6109,8 @@ TclEvalObjEx(
iPtr->evalFlags |= TCL_EVAL_CTX;
result = TclEvalEx(interp, script, numSrcBytes, flags,
- ctxPtr->line[word], NULL, script);
+ ctxPtr->line[word], NULL, script);
}
-
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
/*
* Death of SrcInfo reference.
@@ -5240,54 +6122,87 @@ TclEvalObjEx(
}
/*
- * Now release the lock on the continuation line information, if
- * any, and restore the caller's settings.
+ * Now release the lock on the continuation line information, if any,
+ * and restore the caller's settings.
*/
if (iPtr->scriptCLLocPtr) {
- Tcl_Release (iPtr->scriptCLLocPtr);
+ Tcl_Release(iPtr->scriptCLLocPtr);
}
iPtr->scriptCLLocPtr = saveCLLocPtr;
- } else {
- /*
- * Let the compiler/engine subsystem do the evaluation.
- *
- * TIP #280 The invoker provides us with the context for the script.
- * We transfer this to the byte code compiler.
- */
- int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+ TclDecrRefCount(objPtr);
+ return result;
+ }
+}
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = iPtr->rootFramePtr;
+static int
+TEOEx_ByteCodeCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *savedVarFramePtr = data[0];
+ Tcl_Obj *objPtr = data[1];
+ int allowExceptions = PTR2INT(data[2]);
+
+ if (iPtr->numLevels == 0) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
}
+ if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
+ const char *script;
+ int numSrcBytes;
- result = TclCompEvalObj(interp, objPtr, invoker, word);
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
+ }
/*
- * If we are again at the top level, process any unusual return code
- * returned by the evaluated code.
+ * We are returning to level 0, so should call TclResetCancellation.
+ * Let us just unset the flags inline.
*/
- if (iPtr->numLevels == 0) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)
- && !allowExceptions) {
- ProcessUnexpectedResult(interp, result);
- result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
- }
- }
- iPtr->evalFlags = 0;
+ TclUnsetCancelFlags(iPtr);
+ }
+ iPtr->evalFlags = 0;
+
+ /*
+ * Restore the callFrame if this was a TCL_EVAL_GLOBAL.
+ */
+
+ if (savedVarFramePtr) {
iPtr->varFramePtr = savedVarFramePtr;
}
TclDecrRefCount(objPtr);
return result;
}
+
+static int
+TEOEx_ListCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr = data[0];
+ CmdFrame *eoFramePtr = data[1];
+
+ /*
+ * Remove the cmdFrame
+ */
+
+ if (eoFramePtr) {
+ iPtr->cmdFramePtr = eoFramePtr->nextPtr;
+ TclStackFree(interp, eoFramePtr);
+ }
+ TclDecrRefCount(listPtr);
+
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -5315,6 +6230,8 @@ ProcessUnexpectedResult(
* result code was returned. */
int returnCode) /* The unexpected result code. */
{
+ char buf[TCL_INTEGER_SPACE];
+
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_AppendResult(interp,
@@ -5326,6 +6243,8 @@ ProcessUnexpectedResult(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
}
+ sprintf(buf, "%d", returnCode);
+ Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL);
}
/*
@@ -5476,7 +6395,7 @@ Tcl_ExprLongObj(
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){
+ if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) {
return TCL_ERROR;
}
@@ -5569,6 +6488,7 @@ Tcl_ExprBooleanObj(
*
* Object version: Invokes a Tcl command, given an objv/objc, from either
* the exposed or hidden set of commands in the given interpreter.
+ *
* NOTE: The command is invoked in the global stack frame of the
* interpreter or namespace, thus it cannot see any current state on the
* stack of that interpreter.
@@ -5643,7 +6563,7 @@ TclObjInvoke(
{
register Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
- char *cmdName; /* Name of the command from objv[0]. */
+ const char *cmdName; /* Name of the command from objv[0]. */
Tcl_HashEntry *hPtr = NULL;
Command *cmdPtr;
int result;
@@ -5673,6 +6593,8 @@ TclObjInvoke(
if (hPtr == NULL) {
Tcl_AppendResult(interp, "invalid hidden command name \"",
cmdName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
+ NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
@@ -5682,7 +6604,12 @@ TclObjInvoke(
*/
iPtr->cmdCount++;
- result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
+ if (cmdPtr->objProc != NULL) {
+ result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
+ } else {
+ result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
+ cmdPtr->objClientData, objc, objv);
+ }
/*
* If an error occurred, record information about what was being executed
@@ -5738,7 +6665,7 @@ Tcl_ExprString(
* An empty string. Just set the interpreter's result to 0.
*/
- Tcl_SetResult(interp, "0", TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
} else {
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
@@ -5749,13 +6676,13 @@ Tcl_ExprString(
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
}
+ }
- /*
- * Force the string rep of the interp result.
- */
+ /*
+ * Force the string rep of the interp result.
+ */
- (void) Tcl_GetStringResult(interp);
- }
+ (void) Tcl_GetStringResult(interp);
return code;
}
@@ -5868,7 +6795,7 @@ Tcl_AddObjErrorInfo(
* interp->result completely.
*/
- iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1);
+ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
} else {
iPtr->errorInfo = iPtr->objResultPtr;
}
@@ -5912,7 +6839,7 @@ Tcl_AddObjErrorInfo(
int
Tcl_VarEvalVA(
- Tcl_Interp *interp, /* Interpreter in which to evaluate command. */
+ Tcl_Interp *interp, /* Interpreter in which to evaluate command */
va_list argList) /* Variable argument list. */
{
Tcl_DString buf;
@@ -5993,7 +6920,8 @@ Tcl_VarEval(
int
Tcl_GlobalEval(
- Tcl_Interp *interp, /* Interpreter in which to evaluate command. */
+ Tcl_Interp *interp, /* Interpreter in which to evaluate
+ * command. */
const char *command) /* Command to evaluate. */
{
register Interp *iPtr = (Interp *) interp;
@@ -6151,6 +7079,7 @@ ExprCeilFunc(
if (code != TCL_OK) {
return TCL_ERROR;
}
+
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
mp_clear(&big);
@@ -6186,6 +7115,7 @@ ExprFloorFunc(
if (code != TCL_OK) {
return TCL_ERROR;
}
+
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
mp_clear(&big);
@@ -6207,9 +7137,8 @@ ExprIsqrtFunc(
double d;
Tcl_WideInt w;
mp_int big;
- int exact = 0; /* Flag == 1 if the argument can be
- * represented in a double as an exact
- * integer. */
+ int exact = 0; /* Flag ==1 if the argument can be represented
+ * in a double as an exact integer. */
/*
* Check syntax.
@@ -6286,12 +7215,12 @@ ExprIsqrtFunc(
mp_clear(&big);
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
-
return TCL_OK;
negarg:
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("square root of negative argument", -1));
+ Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
@@ -6366,7 +7295,7 @@ ExprUnaryFunc(
return TCL_ERROR;
}
errno = 0;
- return CheckDoubleResult(interp, (*func)(d));
+ return CheckDoubleResult(interp, func(d));
}
static int
@@ -6437,7 +7366,7 @@ ExprBinaryFunc(
return TCL_ERROR;
}
errno = 0;
- return CheckDoubleResult(interp, (*func)(d1, d2));
+ return CheckDoubleResult(interp, func(d1, d2));
}
static int
@@ -6490,17 +7419,17 @@ ExprAbsFunc(
double d = *((const double *) ptr);
static const double poszero = 0.0;
- /* We need to distinguish here between positive 0.0 and
- * negative -0.0, see Bug ID #2954959.
+ /*
+ * We need to distinguish here between positive 0.0 and negative -0.0.
+ * [Bug 2954959]
*/
+
if (d == -0.0) {
- if (!memcmp(&d, &poszero, sizeof(double))) {
- goto unChanged;
- }
- } else {
- if (d > -0.0) {
+ if (!memcmp(&d, &poszero, sizeof(double))) {
goto unChanged;
}
+ } else if (d > -0.0) {
+ goto unChanged;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
return TCL_OK;
@@ -6523,8 +7452,7 @@ ExprAbsFunc(
#endif
if (type == TCL_NUMBER_BIG) {
- /* TODO: const correctness ? */
- if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) {
+ if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
mp_neg(&big, &big);
@@ -6542,6 +7470,7 @@ ExprAbsFunc(
return TCL_OK;
#else
double d;
+
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
#endif
@@ -6579,6 +7508,7 @@ ExprDoubleFunc(
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
double dResult;
+
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
@@ -6694,6 +7624,7 @@ ExprWideFunc(
{
Tcl_WideInt wResult;
Tcl_Obj *objPtr;
+
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -6743,7 +7674,7 @@ ExprRandFunc(
* to insure different seeds in different threads (bug #416643)
*/
- iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
+ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
@@ -6922,7 +7853,7 @@ ExprSrandFunc(
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
- * ExprRandFunc() for more details.
+ * ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
@@ -6969,7 +7900,7 @@ MathFuncWrongNumArgs(
const char *tail = name + strlen(name);
while (tail > name+1) {
- --tail;
+ tail--;
if (*tail == ':' && tail[-1] == ':') {
name = tail+1;
break;
@@ -6978,9 +7909,10 @@ MathFuncWrongNumArgs(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"too %s arguments for math function \"%s\"",
(found < expected ? "few" : "many"), name));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
}
-#ifdef USE_DTRACE
+#ifdef USE_DTRACE
/*
*----------------------------------------------------------------------
*
@@ -7036,49 +7968,1050 @@ DTraceObjCmd(
void
TclDTraceInfo(
Tcl_Obj *info,
- char **args,
+ const char **args,
int *argsi)
{
- static Tcl_Obj *keys[7] = { NULL };
+ static Tcl_Obj *keys[10] = { NULL };
Tcl_Obj **k = keys, *val;
- int i;
+ int i = 0;
if (!*k) {
- TclNewLiteralStringObj(keys[0], "cmd");
- TclNewLiteralStringObj(keys[1], "type");
- TclNewLiteralStringObj(keys[2], "proc");
- TclNewLiteralStringObj(keys[3], "file");
- TclNewLiteralStringObj(keys[4], "lambda");
- TclNewLiteralStringObj(keys[5], "line");
- TclNewLiteralStringObj(keys[6], "level");
- }
- for (i = 0; i < 4; i++) {
+#define kini(s) TclNewLiteralStringObj(keys[i], s); i++
+ kini("cmd"); kini("type"); kini("proc"); kini("file");
+ kini("method"); kini("class"); kini("lambda"); kini("object");
+ kini("line"); kini("level");
+#undef kini
+ }
+ for (i = 0; i < 6; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
+ /* no "proc" -> use "lambda" */
if (!args[2]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[2] = val ? TclGetString(val) : NULL;
}
k++;
+ /* no "class" -> use "object" */
+ if (!args[5]) {
+ Tcl_DictObjGet(NULL, info, *k, &val);
+ args[5] = val ? TclGetString(val) : NULL;
+ }
+ k++;
for (i = 0; i < 2; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
if (val) {
- TclGetIntFromObj(NULL, val, &(argsi[i]));
+ TclGetIntFromObj(NULL, val, &argsi[i]);
} else {
argsi[i] = 0;
}
}
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DTraceCmdReturn --
+ *
+ * NR callback for DTrace command return probes.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DTraceCmdReturn(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ char *cmdName = TclGetString((Tcl_Obj *) data[0]);
+
+ if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
+ TCL_DTRACE_CMD_RETURN(cmdName, result);
+ }
+ if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
+ Tcl_Obj *r = Tcl_GetObjResult(interp);
+
+ TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r);
+ }
+ return result;
+}
TCL_DTRACE_DEBUG_LOG()
#endif /* USE_DTRACE */
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NRCallObjProc --
+ *
+ * This function calls an objProc directly while managing things properly
+ * if it happens to be an NR objProc. It is meant to be used by extenders
+ * that provide an NR implementation of a command, as this function
+ * permits a trivial coding of the non-NR objProc.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as TCL_OK or
+ * TCL_ERROR. A result or error message is left in interp's result.
+ *
+ * Side effects:
+ * Depends on the objProc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_NRCallObjProc(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc *objProc,
+ ClientData clientData,
+ 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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NRCreateCommand --
+ *
+ * Define a new NRE-enabled object-based command in a command table.
+ *
+ * Results:
+ * The return value is a token for the command, which can be used in
+ * 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.
+ *
+ * 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
+ * Tcl_ObjCmdProc proc will be called. When the command is deleted from
+ * the table, deleteProc will be called. See the manual entry for details
+ * on the calling sequence.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_NRCreateCommand(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc *proc, /* Object-based function to associate with
+ * name, provides direct access for direct
+ * calls. */
+ Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ ClientData clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+ Command *cmdPtr = (Command *)
+ Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+
+ cmdPtr->nreProc = nreProc;
+ return (Tcl_Command) cmdPtr;
+}
+
+/****************************************************************************
+ * Stuff for the public api
+ ****************************************************************************/
+
+int
+Tcl_NREvalObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int flags)
+{
+ return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
+}
+
+int
+Tcl_NREvalObjv(
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the
+ * command. Also used for error reporting. */
+ int objc, /* Number of words in command. */
+ Tcl_Obj *const objv[], /* An array of pointers to objects that are
+ * the words that make up the command. */
+ int flags) /* Collection of OR-ed bits that control the
+ * evaluation of the script. Only
+ * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
+ * TCL_EVAL_NOERR are currently supported. */
+{
+ return TclNREvalObjv(interp, objc, objv, flags, NULL);
+}
+
+int
+Tcl_NRCmdSwap(
+ Tcl_Interp *interp,
+ Tcl_Command cmd,
+ int objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd);
+}
+
+/*****************************************************************************
+ * Stuff for tailcalls
+ *****************************************************************************
+ *
+ * Just to show that IT CAN BE DONE! The precise semantics are not simple,
+ * require more thought. Possibly need a new Tcl return code to do it right?
+ * Questions include:
+ * (1) How is the objc/objv tailcall to be run? My current thinking is that
+ * it should essentially be
+ * [tailcall a b c] <=> [uplevel 1 [list a b c]]
+ * with two caveats
+ * (a) the current frame is dropped first, after running all pending
+ * cleanup tasks and saving its namespace
+ * (b) 'a' is looked up in the returning frame's namespace, but the
+ * command is run in the context to which we are returning
+ * Current implementation does this if [tailcall] is called from within
+ * a proc, errors otherwise.
+ * (2) Should a tailcall bypass [catch] in the returning frame? Current
+ * implementation does not (or does it? Changed, test!) - it causes an
+ * error.
+ *
+ * FIXME NRE!
+ */
+
+void
+TclSpliceTailcall(
+ Tcl_Interp *interp,
+ NRE_callback *tailcallPtr)
+{
+ /*
+ * Find the splicing spot: right before the NRCommand of the thing
+ * being tailcalled. Note that we skip NRCommands marked 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]) {
+ break;
+ }
+ }
+ if (!runPtr) {
+ Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
+ }
+
+ tailcallPtr->nextPtr = runPtr->nextPtr;
+ runPtr->nextPtr = tailcallPtr;
+}
+
+int
+TclNRTailcallObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */
+ Tcl_SetResult(interp,
+ "tailcall can only be called from a proc or lambda",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Invocation without args just clears a scheduled tailcall; invocation
+ * with an argument replaces any previously scheduled tailcall.
+ */
+
+ if (iPtr->varFramePtr->tailcallPtr) {
+ ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ }
+
+ /*
+ * Create the callback to actually evaluate the tailcalled
+ * command, then set it in the varFrame so that PopCallFrame can use it
+ * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
+ * build the callback.
+ */
+
+ if (objc > 1) {
+ 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);
+
+ 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, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
+ tailcallPtr = TOP_CB(interp);
+ TOP_CB(interp) = tailcallPtr->nextPtr;
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+ }
+ return TCL_RETURN;
+}
+
+int
+NRTailcallEval(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr = data[0];
+ Tcl_Obj *nsObjPtr = data[1];
+ Tcl_Namespace *nsPtr;
+ int objc;
+ Tcl_Obj **objv;
+
+ if (result == TCL_OK) {
+ result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+ }
+
+ if (result != TCL_OK) {
+ /*
+ * Tailcall execution was preempted, eg by an intervening catch or by
+ * a now-gone namespace: cleanup and return.
+ */
+
+ TailcallCleanup(data, interp, result);
+ return result;
+ }
+
+ /*
+ * Perform the tailcall
+ */
+
+ TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+ iPtr->lookupNsPtr = (Namespace *) nsPtr;
+ ListObjGetElements(listPtr, objc, objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+static int
+TailcallCleanup(
+ ClientData data[],
+ Tcl_Interp *interp,
+ 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(
+ Tcl_Interp *interp,
+ Tcl_NRPostProc *postProcPtr,
+ ClientData data0,
+ ClientData data1,
+ ClientData data2,
+ ClientData data3)
+{
+ if (!(postProcPtr)) {
+ Tcl_Panic("Adding a callback without an objProc?!");
+ }
+ TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRCoroutineObjCmd -- (and friends)
+ *
+ * This object-based function is invoked to process the "coroutine" Tcl
+ * command. It is heavily based on "apply".
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * A new procedure gets created.
+ *
+ * ** FIRST EXPERIMENTAL IMPLEMENTATION **
+ *
+ * It is fairly amateurish and not up to our standards - mainly in terms of
+ * error messages and [info] interaction. Just to test the infrastructure in
+ * teov and tebc.
+ *----------------------------------------------------------------------
+ */
+
+#define iPtr ((Interp *) interp)
+
+int
+TclNRYieldObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
+ return TCL_ERROR;
+ }
+
+ if (!corPtr) {
+ Tcl_SetResult(interp, "yield can only be called in a coroutine",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ Tcl_SetObjResult(interp, objv[1]);
+ }
+
+ NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
+ TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ clientData, NULL, NULL);
+ return TCL_OK;
+}
+
+int
+TclNRYieldToObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ Tcl_Obj *listPtr, *nsObjPtr;
+ Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+ Tcl_Namespace *ns1Ptr;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (!corPtr) {
+ Tcl_SetResult(interp, "yieldTo can only be called in a coroutine",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Add the tailcall in the caller env, then just yield.
+ *
+ * This is essentially code from TclNRTailcallObjCmd
+ */
+
+ listPtr = Tcl_NewListObj(objc-1, objv+1);
+ Tcl_IncrRefCount(listPtr);
+
+ 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);
+
+ /*
+ * Add the callback in the caller's env, then instruct TEBC to yield.
+ */
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
+ NULL);
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+ return TclNRYieldObjCmd(clientData, 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, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+ cbPtr = TOP_CB(interp);
+ TOP_CB(interp) = cbPtr->nextPtr;
+
+ TclSpliceTailcall(interp, cbPtr);
+ return TCL_OK;
+}
+
+static int
+RewindCoroutineCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ return Tcl_RestoreInterpState(interp, data[0]);
+}
+
+static int
+RewindCoroutine(
+ CoroutineData *corPtr,
+ int result)
+{
+ Tcl_Interp *interp = corPtr->eePtr->interp;
+ Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
+
+ NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
+ NRE_ASSERT(corPtr->eePtr != NULL);
+ NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);
+
+ corPtr->eePtr->rewind = 1;
+ TclNRAddCallback(interp, RewindCoroutineCallback, state,
+ NULL, NULL, NULL);
+ return NRInterpCoroutine(corPtr, interp, 0, NULL);
+}
+
+static void
+DeleteCoroutine(
+ ClientData clientData)
+{
+ CoroutineData *corPtr = clientData;
+ Tcl_Interp *interp = corPtr->eePtr->interp;
+ NRE_callback *rootPtr = TOP_CB(interp);
+
+ if (COR_IS_SUSPENDED(corPtr)) {
+ TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr);
+ }
+}
+
+static int
+NRCoroutineCallerCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Command *cmdPtr = corPtr->cmdPtr;
+
+ /*
+ * This is the last callback in the caller execEnv, right before switching
+ * to the coroutine's
+ */
+
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr);
+
+ if (!corPtr->eePtr) {
+ /*
+ * The execEnv was wound down but not deleted for our sake. We finish
+ * the job here. The caller context has already been restored.
+ */
+
+ NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr);
+ NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
+ NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
+ ckfree(corPtr);
+ return result;
+ }
+
+ NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
+ SAVE_CONTEXT(corPtr->running);
+ RESTORE_CONTEXT(corPtr->caller);
+
+ if (cmdPtr->flags & CMD_IS_DELETED) {
+ /*
+ * The command was deleted while it was running: wind down the
+ * execEnv, this will do the complete cleanup. RewindCoroutine will
+ * restore both the caller's context and interp state.
+ */
+
+ return RewindCoroutine(corPtr, result);
+ }
+
+ return result;
+}
+
+static int
+NRCoroutineExitCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Command *cmdPtr = corPtr->cmdPtr;
+
+ /*
+ * This runs at the bottom of the Coroutine's execEnv: it will be executed
+ * when the coroutine returns or is wound down, but not when it yields. It
+ * deletes the coroutine and restores the caller's environment.
+ */
+
+ NRE_ASSERT(interp == corPtr->eePtr->interp);
+ NRE_ASSERT(TOP_CB(interp) == NULL);
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
+ NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
+ NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback));
+
+ cmdPtr->deleteProc = NULL;
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ TclCleanupCommandMacro(cmdPtr);
+
+ corPtr->eePtr->corPtr = NULL;
+ TclDeleteExecEnv(corPtr->eePtr);
+ corPtr->eePtr = NULL;
+
+ corPtr->stackLevel = NULL;
+
+ /*
+ * #280.
+ * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
+ * command arguments in bytecode.
+ */
+
+ Tcl_DeleteHashTable(corPtr->lineLABCPtr);
+ ckfree(corPtr->lineLABCPtr);
+ corPtr->lineLABCPtr = NULL;
+
+ RESTORE_CONTEXT(corPtr->caller);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ iPtr->numLevels++;
+
+ return result;
+}
+
+
+/*
+ * NRCoroutineActivateCallback --
+ *
+ * This is the workhorse for coroutines: it implements both yield and resume.
+ *
+ * It is important that both be implemented in the same callback: the
+ * detection of the impossibility to suspend due to a busy C-stack relies on
+ * the precise position of a local variable in the stack. We do not want the
+ * compiler to play tricks on us, either by moving things around or inlining.
+ */
+
+static int
+NRCoroutineActivateCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ int type = PTR2INT(data[1]);
+ int numLevels, unused;
+ int *stackLevel = &unused;
+
+ if (!corPtr->stackLevel) {
+ /*
+ * -- Coroutine is suspended --
+ * Push the callback to restore the caller's context on yield or return
+ */
+
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL,
+ NULL);
+
+ /*
+ * Record the stackLevel at which the resume is happening, then swap
+ * the interp's environment to make it suitable to run this
+ * coroutine.
+ */
+
+ corPtr->stackLevel = stackLevel;
+ numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = iPtr->numLevels;
+
+ SAVE_CONTEXT(corPtr->caller);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ RESTORE_CONTEXT(corPtr->running);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ iPtr->numLevels += numLevels;
+
+ return TCL_OK;
+ } else {
+ /*
+ * Coroutine is active: yield
+ */
+
+ if (corPtr->stackLevel != stackLevel) {
+ Tcl_SetResult(interp, "cannot yield: C stack busy",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ if (type == CORO_ACTIVATE_YIELD) {
+ corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
+ } else if (type == CORO_ACTIVATE_YIELDM) {
+ corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
+ } else {
+ Tcl_Panic("Yield received an option which is not implemented");
+ }
+
+ corPtr->stackLevel = NULL;
+
+ numLevels = iPtr->numLevels;
+ iPtr->numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ return TCL_OK;
+ }
+}
+
+
+static int
+NRCoroInjectObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Command *cmdPtr;
+ CoroutineData *corPtr;
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+
+ /*
+ * Usage more or less like tailcall:
+ * inject coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+ if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1));
+ return TCL_ERROR;
+ }
+
+ corPtr = (CoroutineData *) cmdPtr->objClientData;
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed
+ */
+
+ iPtr->execEnvPtr = corPtr->eePtr;
+ Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ return TCL_OK;
+}
+
+int
+NRInterpCoroutine(
+ ClientData clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ CoroutineData *corPtr = clientData;
+
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
+ "\" is already running", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse all the arguments to work out what to feed as the result of the
+ * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine
+ * is deleted!
+ */
+
+ switch (corPtr->nargs) {
+ case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
+ if (objc == 2) {
+ Tcl_SetObjResult(interp, objv[1]);
+ } else if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
+ return TCL_ERROR;
+ }
+ break;
+ default:
+ if (corPtr->nargs != objc-1) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("wrong coro nargs; how did we get here? "
+ "not implemented!", -1));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+ /* fallthrough */
+ case COROUTINE_ARGUMENTS_ARBITRARY:
+ if (objc > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));
+ }
+ break;
+ }
+
+ TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ NULL, NULL, NULL);
+ return TCL_OK;
+}
+
+int
+TclNRCoroutineObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Command *cmdPtr;
+ CoroutineData *corPtr;
+ const char *fullName, *procName;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+ Tcl_DString ds;
+ Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
+ * something in tclUtil.c to find the FQ name.
+ */
+
+ fullName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, fullName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+
+ if (nsPtr == NULL) {
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
+ "\": unknown namespace", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
+ return TCL_ERROR;
+ }
+ if (procName == NULL) {
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
+ "\": bad procedure name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
+ return TCL_ERROR;
+ }
+ if ((nsPtr != iPtr->globalNsPtr)
+ && (procName != NULL) && (procName[0] == ':')) {
+ Tcl_AppendResult(interp, "can't create procedure \"", procName,
+ "\" in non-global namespace with name starting with \":\"",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * We ARE creating the coroutine command: allocate the corresponding
+ * struct and create the corresponding command.
+ */
+
+ corPtr = ckalloc(sizeof(CoroutineData));
+
+ Tcl_DStringInit(&ds);
+ if (nsPtr != iPtr->globalNsPtr) {
+ Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
+ Tcl_DStringAppend(&ds, "::", 2);
+ }
+ Tcl_DStringAppend(&ds, procName, -1);
+
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
+ /*objProc*/ NULL, NRInterpCoroutine, corPtr, DeleteCoroutine);
+ Tcl_DStringFree(&ds);
+
+ corPtr->cmdPtr = cmdPtr;
+ cmdPtr->refCount++;
+
+ /*
+ * #280.
+ * Provide the new coroutine with its own copy of the lineLABCPtr
+ * hashtable for literal command arguments in bytecode. Note that that
+ * CFWordBC chains are not duplicated, only the entrypoints to them. This
+ * means that in the presence of coroutines each chain is potentially a
+ * tree. Like the chain -> tree conversion of the CmdFrame stack.
+ */
+
+ {
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hePtr;
+
+ corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
+
+ for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
+ hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) {
+ int isNew;
+ Tcl_HashEntry *newPtr =
+ Tcl_CreateHashEntry(corPtr->lineLABCPtr,
+ Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr),
+ &isNew);
+
+ Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
+ }
+ }
+
+ /*
+ * Create the base context.
+ */
+
+ corPtr->running.framePtr = iPtr->rootFramePtr;
+ corPtr->running.varFramePtr = iPtr->rootFramePtr;
+ corPtr->running.cmdFramePtr = NULL;
+ corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
+ corPtr->stackLevel = NULL;
+ corPtr->auxNumLevels = 0;
+ iPtr->numLevels--;
+
+ /*
+ * Create the coro's execEnv, switch to it to push the exit and coro
+ * command callbacks, then switch back.
+ */
+
+ corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ corPtr->eePtr->corPtr = corPtr;
+
+ SAVE_CONTEXT(corPtr->caller);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ RESTORE_CONTEXT(corPtr->running);
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+ TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
+ NULL, NULL, NULL);
+
+ iPtr->lookupNsPtr = lookupNsPtr;
+ Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+
+ SAVE_CONTEXT(corPtr->running);
+ RESTORE_CONTEXT(corPtr->caller);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+
+ /*
+ * Now just resume the coroutine. Take care to insure that the command is
+ * looked up in the correct namespace.
+ */
+
+ TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ NULL, NULL, NULL);
+ return TCL_OK;
+}
+
+/*
+ * This is used in the [info] ensemble
+ */
+
+int
+TclInfoCoroutineCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ Tcl_Obj *namePtr;
+
+ TclNewObj(namePtr);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr);
+ Tcl_SetObjResult(interp, namePtr);
+ }
+ return TCL_OK;
+}
+
+#undef iPtr
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 90d392b..0a340f2 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -59,7 +59,7 @@ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr,
static int FormatNumber(Tcl_Interp *interp, int type,
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
-static int GetFormatSpec(char **formatPtr, char *cmdPtr,
+static int GetFormatSpec(const char **formatPtr, char *cmdPtr,
int *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
int flags, Tcl_HashTable **numberCachePtr);
@@ -69,7 +69,63 @@ static void UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int NeedReversing(int format);
static void CopyNumber(const void *from, void *to,
- unsigned int length, int type);
+ unsigned length, int type);
+/* Binary ensemble commands */
+static int BinaryFormatCmd(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int BinaryScanCmd(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+/* Binary encoding sub-ensemble commands */
+static int BinaryEncodeHex(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int BinaryDecodeHex(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int BinaryEncode64(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[]);
+static int BinaryDecode64(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+
+/*
+ * The following tables are used by the binary encoders
+ */
+
+static const char HexDigits[16] = {
+ '0', '1', '2', '3', '4', '5', '6', '7',
+ '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'
+};
+
+static const char UueDigits[65] = {
+ '`', '!', '"', '#', '$', '%', '&', '\'',
+ '(', ')', '*', '+', ',', '-', '.', '/',
+ '0', '1', '2', '3', '4', '5', '6', '7',
+ '8', '9', ':', ';', '<', '=', '>', '?',
+ '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', '[', '\\',']', '^', '_',
+ '`'
+};
+
+static const char B64Digits[65] = {
+ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
+ 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P',
+ 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X',
+ 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f',
+ 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',
+ 'o', 'p', 'q', 'r', 's', 't', 'u', 'v',
+ 'w', 'x', 'y', 'z', '0', '1', '2', '3',
+ '4', '5', '6', '7', '8', '9', '+', '/',
+ '='
+};
/*
* The following object type represents an array of bytes. An array of bytes
@@ -96,7 +152,7 @@ static void CopyNumber(const void *from, void *to,
* converting an arbitrary String to a ByteArray may be.
*/
-Tcl_ObjType tclByteArrayType = {
+const Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
@@ -116,18 +172,17 @@ typedef struct ByteArray {
* array. */
int allocated; /* The amount of space actually allocated
* minus 1 byte. */
- unsigned char bytes[4]; /* The array of bytes. The actual size of this
+ unsigned char bytes[1]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
- ((unsigned) (sizeof(ByteArray) - 4 + (len)))
+ ((unsigned) (TclOffset(ByteArray, bytes) + (len)))
#define GET_BYTEARRAY(objPtr) \
((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
-
+ (objPtr)->internalRep.otherValuePtr = (void *) (baPtr)
/*
*----------------------------------------------------------------------
@@ -147,7 +202,6 @@ typedef struct ByteArray {
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj
Tcl_Obj *
@@ -157,25 +211,16 @@ Tcl_NewByteArrayObj(
int length) /* Length of the array of bytes, which must be
* >= 0. */
{
+#ifdef TCL_MEM_DEBUG
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
-}
-
#else /* if not TCL_MEM_DEBUG */
-
-Tcl_Obj *
-Tcl_NewByteArrayObj(
- const unsigned char *bytes, /* The array of bytes used to initialize the
- * new object. */
- int length) /* Length of the array of bytes, which must be
- * >= 0. */
-{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
-}
#endif /* TCL_MEM_DEBUG */
+}
/*
*----------------------------------------------------------------------
@@ -202,8 +247,6 @@ Tcl_NewByteArrayObj(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
-
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
@@ -215,30 +258,17 @@ Tcl_DbNewByteArrayObj(
int line) /* Line number in the source file; used for
* debugging. */
{
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
-}
-
#else /* if not TCL_MEM_DEBUG */
-
-Tcl_Obj *
-Tcl_DbNewByteArrayObj(
- const unsigned char *bytes, /* The array of bytes used to initialize the
- * new object. */
- int length, /* Length of the array of bytes, which must be
- * >= 0. */
- const char *file, /* The name of the source file calling this
- * procedure; used for debugging. */
- int line) /* Line number in the source file; used for
- * debugging. */
-{
return Tcl_NewByteArrayObj(bytes, length);
-}
#endif /* TCL_MEM_DEBUG */
-
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -261,9 +291,9 @@ void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new
- * value. */
- int length) /* Length of the array of bytes, which must be
- * >= 0. */
+ value. May be NULL even if length > 0. */
+ int length) /* Length of the array of bytes, which must
+ be >= 0. */
{
ByteArray *byteArrayPtr;
@@ -273,10 +303,14 @@ Tcl_SetByteArrayObj(
TclFreeIntRep(objPtr);
Tcl_InvalidateStringRep(objPtr);
- byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+ length = (length < 0) ? 0 : length;
+ byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
+ memset(byteArrayPtr, 0, BYTEARRAY_SIZE(length));
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
- memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+ if (bytes && length) {
+ memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+ }
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
@@ -357,8 +391,7 @@ Tcl_SetByteArrayLength(
byteArrayPtr = GET_BYTEARRAY(objPtr);
if (length > byteArrayPtr->allocated) {
- byteArrayPtr = (ByteArray *) ckrealloc(
- (char *) byteArrayPtr, BYTEARRAY_SIZE(length));
+ byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
byteArrayPtr->allocated = length;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
@@ -389,7 +422,7 @@ SetByteArrayFromAny(
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
int length;
- char *src, *srcEnd;
+ const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
@@ -398,10 +431,10 @@ SetByteArrayFromAny(
src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
- byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+ byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += Tcl_UtfToUniChar(src, &ch);
- *dst++ = (unsigned char) ch;
+ *dst++ = UCHAR(ch);
}
byteArrayPtr->used = dst - byteArrayPtr->bytes;
@@ -435,7 +468,7 @@ static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree((char *) GET_BYTEARRAY(objPtr));
+ ckfree(GET_BYTEARRAY(objPtr));
objPtr->typePtr = NULL;
}
@@ -467,7 +500,7 @@ DupByteArrayInternalRep(
srcArrayPtr = GET_BYTEARRAY(srcPtr);
length = srcArrayPtr->used;
- copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
@@ -526,7 +559,7 @@ UpdateStringOfByteArray(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- dst = (char *) ckalloc((unsigned) (size + 1));
+ dst = ckalloc(size + 1);
objPtr->bytes = dst;
objPtr->length = size;
@@ -544,9 +577,154 @@ UpdateStringOfByteArray(
/*
*----------------------------------------------------------------------
*
- * Tcl_BinaryObjCmd --
+ * TclAppendBytesToByteArray --
+ *
+ * This function appends an array of bytes to a byte array object. Note
+ * that the object *must* be unshared, and the array of bytes *must not*
+ * refer to the object being appended to. Also the caller must have
+ * already checked that the final length of the bytearray after the
+ * append operations is complete will not overflow the int range.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocates enough memory for an array of bytes of the requested total
+ * size, or possibly larger. [Bug 2992970]
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclAppendBytesToByteArray(
+ Tcl_Obj *objPtr,
+ const unsigned char *bytes,
+ int len)
+{
+ ByteArray *byteArrayPtr;
+
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
+ }
+ if (len < 0) {
+ Tcl_Panic("%s must be called with definite number of bytes to append",
+ "TclAppendBytesToByteArray");
+ }
+ if (objPtr->typePtr != &tclByteArrayType) {
+ SetByteArrayFromAny(NULL, objPtr);
+ }
+ byteArrayPtr = GET_BYTEARRAY(objPtr);
+
+ /*
+ * If we need to, resize the allocated space in the byte array.
+ */
+
+ if (byteArrayPtr->used + len > byteArrayPtr->allocated) {
+ unsigned int attempt, used = byteArrayPtr->used;
+ ByteArray *tmpByteArrayPtr = NULL;
+
+ attempt = byteArrayPtr->allocated;
+ if (attempt < 1) {
+ /*
+ * No allocated bytes, so must be none used too. We use this
+ * method to calculate how many bytes to allocate because we can
+ * end up with a zero-length buffer otherwise, when doubling can
+ * cause trouble. [Bug 3067036]
+ */
+
+ attempt = len + 1;
+ } else {
+ do {
+ attempt *= 2;
+ } while (attempt < used+len);
+ }
+
+ if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) {
+ tmpByteArrayPtr = attemptckrealloc(byteArrayPtr,
+ BYTEARRAY_SIZE(attempt));
+ }
+
+ if (tmpByteArrayPtr == NULL) {
+ attempt = used + len;
+ if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) {
+ Tcl_Panic("attempt to allocate a bigger buffer than we can handle");
+ }
+ tmpByteArrayPtr = ckrealloc(byteArrayPtr,
+ BYTEARRAY_SIZE(attempt));
+ }
+
+ byteArrayPtr = tmpByteArrayPtr;
+ byteArrayPtr->allocated = attempt;
+ byteArrayPtr->used = used;
+ SET_BYTEARRAY(objPtr, byteArrayPtr);
+ }
+
+ /*
+ * Do the append if there's any point.
+ */
+
+ if (len > 0) {
+ memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
+ byteArrayPtr->used += len;
+ Tcl_InvalidateStringRep(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitBinaryCmd --
*
- * This procedure implements the "binary" Tcl command.
+ * This function is called to create the "binary" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A command token for the new command.
+ *
+ * Side effects:
+ * Creates a new binary command as a mapped ensemble.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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)
+{
+ Tcl_Command binaryEnsemble;
+
+ binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap);
+ TclMakeEnsemble(interp, "binary encode", encodeMap);
+ TclMakeEnsemble(interp, "binary decode", decodeMap);
+ return binaryEnsemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryFormatCmd --
+ *
+ * This procedure implements the "binary format" Tcl command.
*
* Results:
* A standard Tcl result.
@@ -557,8 +735,8 @@ UpdateStringOfByteArray(
*----------------------------------------------------------------------
*/
-int
-Tcl_BinaryObjCmd(
+static int
+BinaryFormatCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -571,7 +749,7 @@ Tcl_BinaryObjCmd(
int count; /* Count associated with current format
* character. */
int flags; /* Format field flags */
- char *format; /* Pointer to current position in format
+ const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
@@ -579,785 +757,826 @@ Tcl_BinaryObjCmd(
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
const char *errorString;
- char *errorValue, *str;
- int offset, size, length, index;
- static const char *options[] = {
- "format", "scan", NULL
- };
- enum options {
- BINARY_FORMAT, BINARY_SCAN
- };
+ const char *errorValue, *str;
+ int offset, size, length;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
+ /*
+ * To avoid copying the data, we format the string in two passes. The
+ * first pass computes the size of the output buffer. The second pass
+ * places the formatted data into the buffer.
+ */
- switch ((enum options) index) {
- case BINARY_FORMAT:
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
- return TCL_ERROR;
+ format = TclGetString(objv[1]);
+ arg = 2;
+ offset = 0;
+ length = 0;
+ while (*format != '\0') {
+ str = format;
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ break;
}
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ case 'b':
+ case 'B':
+ case 'h':
+ case 'H':
+ /*
+ * For string-type specifiers, the count corresponds to the number
+ * of bytes in a single argument.
+ */
- /*
- * To avoid copying the data, we format the string in two passes. The
- * first pass computes the size of the output buffer. The second pass
- * places the formatted data into the buffer.
- */
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ Tcl_GetByteArrayFromObj(objv[arg], &count);
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ arg++;
+ if (cmd == 'a' || cmd == 'A') {
+ offset += count;
+ } else if (cmd == 'b' || cmd == 'B') {
+ offset += (count + 7) / 8;
+ } else {
+ offset += (count + 1) / 2;
+ }
+ break;
+ case 'c':
+ size = 1;
+ goto doNumbers;
+ case 't':
+ case 's':
+ case 'S':
+ size = 2;
+ goto doNumbers;
+ case 'n':
+ case 'i':
+ case 'I':
+ size = 4;
+ goto doNumbers;
+ case 'm':
+ case 'w':
+ case 'W':
+ size = 8;
+ goto doNumbers;
+ case 'r':
+ case 'R':
+ case 'f':
+ size = sizeof(float);
+ goto doNumbers;
+ case 'q':
+ case 'Q':
+ case 'd':
+ size = sizeof(double);
+
+ doNumbers:
+ if (arg >= objc) {
+ goto badIndex;
+ }
- format = TclGetString(objv[2]);
- arg = 3;
- offset = 0;
- length = 0;
- while (*format != '\0') {
- str = format;
- flags = 0;
- if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
- break;
- }
- switch (cmd) {
- case 'a':
- case 'A':
- case 'b':
- case 'B':
- case 'h':
- case 'H':
- /*
- * For string-type specifiers, the count corresponds to the
- * number of bytes in a single argument.
- */
+ /*
+ * For number-type specifiers, the count corresponds to the number
+ * of elements in the list stored in a single argument. If no
+ * count is specified, then the argument is taken as a single
+ * non-list value.
+ */
- if (arg >= objc) {
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- Tcl_GetByteArrayFromObj(objv[arg], &count);
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
+ if (count == BINARY_NOCOUNT) {
arg++;
- if (cmd == 'a' || cmd == 'A') {
- offset += count;
- } else if (cmd == 'b' || cmd == 'B') {
- offset += (count + 7) / 8;
- } else {
- offset += (count + 1) / 2;
- }
- break;
- case 'c':
- size = 1;
- goto doNumbers;
- case 't':
- case 's':
- case 'S':
- size = 2;
- goto doNumbers;
- case 'n':
- case 'i':
- case 'I':
- size = 4;
- goto doNumbers;
- case 'm':
- case 'w':
- case 'W':
- size = 8;
- goto doNumbers;
- case 'r':
- case 'R':
- case 'f':
- size = sizeof(float);
- goto doNumbers;
- case 'q':
- case 'Q':
- case 'd':
- size = sizeof(double);
-
- doNumbers:
- if (arg >= objc) {
- goto badIndex;
- }
+ count = 1;
+ } else {
+ int listc;
+ Tcl_Obj **listv;
/*
- * For number-type specifiers, the count corresponds to the
- * number of elements in the list stored in a single argument.
- * If no count is specified, then the argument is taken as a
- * single non-list value.
+ * The macro evals its args more than once: avoid arg++
*/
- if (count == BINARY_NOCOUNT) {
- arg++;
- count = 1;
- } else {
- int listc;
- Tcl_Obj **listv;
-
- /* The macro evals its args more than once: avoid arg++ */
- if (TclListObjGetElements(interp, objv[arg], &listc,
- &listv) != TCL_OK) {
- return TCL_ERROR;
- }
- arg++;
-
- if (count == BINARY_ALL) {
- count = listc;
- } else if (count > listc) {
- Tcl_AppendResult(interp,
- "number of elements in list does not match count",
- NULL);
- return TCL_ERROR;
- }
+ if (TclListObjGetElements(interp, objv[arg], &listc,
+ &listv) != TCL_OK) {
+ return TCL_ERROR;
}
- offset += count*size;
- break;
+ arg++;
- case 'x':
if (count == BINARY_ALL) {
+ count = listc;
+ } else if (count > listc) {
Tcl_AppendResult(interp,
- "cannot use \"*\" in format string with \"x\"",
+ "number of elements in list does not match count",
NULL);
return TCL_ERROR;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
}
- offset += count;
- break;
- case 'X':
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count > offset) || (count == BINARY_ALL)) {
- count = offset;
- }
- if (offset > length) {
- length = offset;
- }
- offset -= count;
- break;
- case '@':
- if (offset > length) {
- length = offset;
- }
- if (count == BINARY_ALL) {
- offset = length;
- } else if (count == BINARY_NOCOUNT) {
- goto badCount;
- } else {
- offset = count;
- }
- break;
- default:
- errorString = str;
- goto badField;
}
+ offset += count*size;
+ break;
+
+ case 'x':
+ if (count == BINARY_ALL) {
+ Tcl_AppendResult(interp,
+ "cannot use \"*\" in format string with \"x\"",
+ NULL);
+ return TCL_ERROR;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ offset += count;
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count > offset) || (count == BINARY_ALL)) {
+ count = offset;
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ offset -= count;
+ break;
+ case '@':
+ if (offset > length) {
+ length = offset;
+ }
+ if (count == BINARY_ALL) {
+ offset = length;
+ } else if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ } else {
+ offset = count;
+ }
+ break;
+ default:
+ errorString = str;
+ goto badField;
}
- if (offset > length) {
- length = offset;
- }
- if (length == 0) {
- return TCL_OK;
- }
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ if (length == 0) {
+ return TCL_OK;
+ }
- /*
- * Prepare the result object by preallocating the caclulated number of
- * bytes and filling with nulls.
- */
+ /*
+ * Prepare the result object by preallocating the caclulated number of
+ * bytes and filling with nulls.
+ */
- resultPtr = Tcl_NewObj();
- buffer = Tcl_SetByteArrayLength(resultPtr, length);
- memset(buffer, 0, (size_t) length);
+ resultPtr = Tcl_NewObj();
+ buffer = Tcl_SetByteArrayLength(resultPtr, length);
+ memset(buffer, 0, (size_t) length);
- /*
- * Pack the data into the result object. Note that we can skip the
- * error checking during this pass, since we have already parsed the
- * string once.
- */
+ /*
+ * Pack the data into the result object. Note that we can skip the
+ * error checking during this pass, since we have already parsed the
+ * string once.
+ */
- arg = 3;
- format = TclGetString(objv[2]);
- cursor = buffer;
- maxPos = cursor;
- while (*format != 0) {
- flags = 0;
- if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
- break;
- }
- if ((count == 0) && (cmd != '@')) {
- if (cmd != 'x') {
- arg++;
- }
- continue;
+ arg = 2;
+ format = TclGetString(objv[1]);
+ cursor = buffer;
+ maxPos = cursor;
+ while (*format != 0) {
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ break;
+ }
+ if ((count == 0) && (cmd != '@')) {
+ if (cmd != 'x') {
+ arg++;
}
- switch (cmd) {
- case 'a':
- case 'A': {
- char pad = (char) (cmd == 'a' ? '\0' : ' ');
- unsigned char *bytes;
-
- bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
-
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (length >= count) {
- memcpy(cursor, bytes, (size_t) count);
- } else {
- memcpy(cursor, bytes, (size_t) length);
- memset(cursor + length, pad, (size_t) (count - length));
- }
- cursor += count;
- break;
+ continue;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ char pad = (char) (cmd == 'a' ? '\0' : ' ');
+ unsigned char *bytes;
+
+ bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
+
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- case 'b':
- case 'B': {
- unsigned char *last;
-
- str = TclGetStringFromObj(objv[arg], &length);
- arg++;
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- last = cursor + ((count + 7) / 8);
- if (count > length) {
- count = length;
- }
- value = 0;
- errorString = "binary";
- if (cmd == 'B') {
- for (offset = 0; offset < count; offset++) {
- value <<= 1;
- if (str[offset] == '1') {
- value |= 1;
- } else if (str[offset] != '0') {
- errorValue = str;
- Tcl_DecrRefCount(resultPtr);
- goto badValue;
- }
- if (((offset + 1) % 8) == 0) {
- *cursor++ = (unsigned char) value;
- value = 0;
- }
+ if (length >= count) {
+ memcpy(cursor, bytes, (size_t) count);
+ } else {
+ memcpy(cursor, bytes, (size_t) length);
+ memset(cursor + length, pad, (size_t) (count - length));
+ }
+ cursor += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ unsigned char *last;
+
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 7) / 8);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "binary";
+ if (cmd == 'B') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 1;
+ if (str[offset] == '1') {
+ value |= 1;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- } else {
- for (offset = 0; offset < count; offset++) {
- value >>= 1;
- if (str[offset] == '1') {
- value |= 128;
- } else if (str[offset] != '0') {
- errorValue = str;
- Tcl_DecrRefCount(resultPtr);
- goto badValue;
- }
- if (!((offset + 1) % 8)) {
- *cursor++ = (unsigned char) value;
- value = 0;
- }
+ if (((offset + 1) % 8) == 0) {
+ *cursor++ = UCHAR(value);
+ value = 0;
}
}
- if ((offset % 8) != 0) {
- if (cmd == 'B') {
- value <<= 8 - (offset % 8);
- } else {
- value >>= 8 - (offset % 8);
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 1;
+ if (str[offset] == '1') {
+ value |= 128;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
+ }
+ if (!((offset + 1) % 8)) {
+ *cursor++ = UCHAR(value);
+ value = 0;
}
- *cursor++ = (unsigned char) value;
- }
- while (cursor < last) {
- *cursor++ = '\0';
}
- break;
}
- case 'h':
- case 'H': {
- unsigned char *last;
- int c;
-
- str = TclGetStringFromObj(objv[arg], &length);
- arg++;
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- last = cursor + ((count + 1) / 2);
- if (count > length) {
- count = length;
+ if ((offset % 8) != 0) {
+ if (cmd == 'B') {
+ value <<= 8 - (offset % 8);
+ } else {
+ value >>= 8 - (offset % 8);
}
- value = 0;
- errorString = "hexadecimal";
- if (cmd == 'H') {
- for (offset = 0; offset < count; offset++) {
- value <<= 4;
- if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
- errorValue = str;
- Tcl_DecrRefCount(resultPtr);
- goto badValue;
- }
- c = str[offset] - '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
- }
- value |= (c & 0xf);
- if (offset % 2) {
- *cursor++ = (char) value;
- value = 0;
- }
+ *cursor++ = UCHAR(value);
+ }
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'h':
+ case 'H': {
+ unsigned char *last;
+ int c;
+
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 1) / 2);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "hexadecimal";
+ if (cmd == 'H') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 4;
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- } else {
- for (offset = 0; offset < count; offset++) {
- value >>= 4;
-
- if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
- errorValue = str;
- Tcl_DecrRefCount(resultPtr);
- goto badValue;
- }
- c = str[offset] - '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
- }
- value |= ((c << 4) & 0xf0);
- if (offset % 2) {
- *cursor++ = (unsigned char)(value & 0xff);
- value = 0;
- }
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
}
- }
- if (offset % 2) {
- if (cmd == 'H') {
- value <<= 4;
- } else {
- value >>= 4;
+ if (c > 16) {
+ c += ('A' - 'a');
}
- *cursor++ = (unsigned char) value;
- }
-
- while (cursor < last) {
- *cursor++ = '\0';
- }
- break;
- }
- case 'c':
- case 't':
- case 's':
- case 'S':
- case 'n':
- case 'i':
- case 'I':
- case 'm':
- case 'w':
- case 'W':
- case 'r':
- case 'R':
- case 'd':
- case 'q':
- case 'Q':
- case 'f': {
- int listc, i;
- Tcl_Obj **listv;
-
- if (count == BINARY_NOCOUNT) {
- /*
- * Note that we are casting away the const-ness of objv,
- * but this is safe since we aren't going to modify the
- * array.
- */
-
- listv = (Tcl_Obj**)(objv + arg);
- listc = 1;
- count = 1;
- } else {
- TclListObjGetElements(interp, objv[arg], &listc, &listv);
- if (count == BINARY_ALL) {
- count = listc;
+ value |= (c & 0xf);
+ if (offset % 2) {
+ *cursor++ = (char) value;
+ value = 0;
}
}
- arg++;
- for (i = 0; i < count; i++) {
- if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 4;
+
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
+ errorValue = str;
Tcl_DecrRefCount(resultPtr);
- return TCL_ERROR;
+ goto badValue;
+ }
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
+ }
+ value |= ((c << 4) & 0xf0);
+ if (offset % 2) {
+ *cursor++ = UCHAR(value & 0xff);
+ value = 0;
}
}
- break;
}
- case 'x':
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- memset(cursor, 0, (size_t) count);
- cursor += count;
- break;
- case 'X':
- if (cursor > maxPos) {
- maxPos = cursor;
- }
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
- cursor = buffer;
+ if (offset % 2) {
+ if (cmd == 'H') {
+ value <<= 4;
} else {
- cursor -= count;
- }
- break;
- case '@':
- if (cursor > maxPos) {
- maxPos = cursor;
+ value >>= 4;
}
+ *cursor++ = UCHAR(value);
+ }
+
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'c':
+ case 't':
+ case 's':
+ case 'S':
+ case 'n':
+ case 'i':
+ case 'I':
+ case 'm':
+ case 'w':
+ case 'W':
+ case 'r':
+ case 'R':
+ case 'd':
+ case 'q':
+ case 'Q':
+ case 'f': {
+ int listc, i;
+ Tcl_Obj **listv;
+
+ if (count == BINARY_NOCOUNT) {
+ /*
+ * Note that we are casting away the const-ness of objv, but
+ * this is safe since we aren't going to modify the array.
+ */
+
+ listv = (Tcl_Obj **) (objv + arg);
+ listc = 1;
+ count = 1;
+ } else {
+ TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
- cursor = maxPos;
- } else {
- cursor = buffer + count;
+ count = listc;
}
- break;
}
+ arg++;
+ for (i = 0; i < count; i++) {
+ if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ return TCL_ERROR;
+ }
+ }
+ break;
}
- Tcl_SetObjResult(interp, resultPtr);
- break;
- case BINARY_SCAN: {
- int i;
- Tcl_Obj *valuePtr, *elementPtr;
- Tcl_HashTable numberCacheHash;
- Tcl_HashTable *numberCachePtr;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "value formatString ?varName varName ...?");
- return TCL_ERROR;
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ memset(cursor, 0, (size_t) count);
+ cursor += count;
+ break;
+ case 'X':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
+ cursor = buffer;
+ } else {
+ cursor -= count;
+ }
+ break;
+ case '@':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_ALL) {
+ cursor = maxPos;
+ } else {
+ cursor = buffer + count;
+ }
+ break;
+ }
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+
+ badValue:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "expected ", errorString,
+ " string but got \"", errorValue, "\" instead", NULL);
+ return TCL_ERROR;
+
+ badCount:
+ errorString = "missing count for \"@\" field specifier";
+ goto error;
+
+ badIndex:
+ errorString = "not enough arguments for all format specifiers";
+ goto error;
+
+ badField:
+ {
+ Tcl_UniChar ch;
+ char buf[TCL_UTF_MAX + 1];
+
+ Tcl_UtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ error:
+ Tcl_AppendResult(interp, errorString, NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryScanCmd --
+ *
+ * This procedure implements the "binary scan" Tcl command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+BinaryScanCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int arg; /* Index of next argument to consume. */
+ int value = 0; /* Current integer value to be packed.
+ * Initialized to avoid compiler warning. */
+ char cmd; /* Current format character. */
+ int count; /* Count associated with current format
+ * character. */
+ int flags; /* Format field flags */
+ const char *format; /* Pointer to current position in format
+ * string. */
+ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
+ unsigned char *buffer; /* Start of result buffer. */
+ const char *errorString;
+ const char *str;
+ int offset, size, length;
+
+ int i;
+ Tcl_Obj *valuePtr, *elementPtr;
+ Tcl_HashTable numberCacheHash;
+ Tcl_HashTable *numberCachePtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "value formatString ?varName ...?");
+ return TCL_ERROR;
+ }
+ numberCachePtr = &numberCacheHash;
+ Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
+ buffer = Tcl_GetByteArrayFromObj(objv[1], &length);
+ format = TclGetString(objv[2]);
+ arg = 3;
+ offset = 0;
+ while (*format != '\0') {
+ str = format;
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ goto done;
}
- numberCachePtr = &numberCacheHash;
- Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
- buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
- format = TclGetString(objv[3]);
- cursor = buffer;
- arg = 4;
- offset = 0;
- while (*format != '\0') {
- str = format;
- flags = 0;
- if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
- goto done;
- }
- switch (cmd) {
- case 'a':
- case 'A': {
- unsigned char *src;
-
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ unsigned char *src;
+
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = length - offset;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- if (count == BINARY_ALL) {
- count = length - offset;
- } else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset)) {
- goto done;
- }
+ if (count > (length - offset)) {
+ goto done;
}
+ }
- src = buffer + offset;
- size = count;
+ src = buffer + offset;
+ size = count;
- /*
- * Trim trailing nulls and spaces, if necessary.
- */
+ /*
+ * Trim trailing nulls and spaces, if necessary.
+ */
- if (cmd == 'A') {
- while (size > 0) {
- if (src[size-1] != '\0' && src[size-1] != ' ') {
- break;
- }
- size--;
+ if (cmd == 'A') {
+ while (size > 0) {
+ if (src[size-1] != '\0' && src[size-1] != ' ') {
+ break;
}
+ size--;
}
+ }
- /*
- * Have to do this #ifdef-fery because (as part of defining
- * Tcl_NewByteArrayObj) we removed the #def that hides this
- * stuff normally. If this code ever gets copied to another
- * file, it should be changed back to the simpler version.
- */
+ /*
+ * Have to do this #ifdef-fery because (as part of defining
+ * Tcl_NewByteArrayObj) we removed the #def that hides this stuff
+ * normally. If this code ever gets copied to another file, it
+ * should be changed back to the simpler version.
+ */
#ifdef TCL_MEM_DEBUG
- valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
+ valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__, __LINE__);
#else
- valuePtr = Tcl_NewByteArrayObj(src, size);
+ valuePtr = Tcl_NewByteArrayObj(src, size);
#endif /* TCL_MEM_DEBUG */
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- offset += count;
- break;
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
}
- case 'b':
- case 'B': {
- unsigned char *src;
- char *dest;
+ offset += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ unsigned char *src;
+ char *dest;
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- count = (length - offset) * 8;
- } else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset) * 8) {
- goto done;
- }
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset) * 8;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- src = buffer + offset;
- valuePtr = Tcl_NewObj();
- Tcl_SetObjLength(valuePtr, count);
- dest = TclGetString(valuePtr);
-
- if (cmd == 'b') {
- for (i = 0; i < count; i++) {
- if (i % 8) {
- value >>= 1;
- } else {
- value = *src++;
- }
- *dest++ = (char) ((value & 1) ? '1' : '0');
- }
- } else {
- for (i = 0; i < count; i++) {
- if (i % 8) {
- value <<= 1;
- } else {
- value = *src++;
- }
- *dest++ = (char) ((value & 0x80) ? '1' : '0');
- }
+ if (count > (length - offset) * 8) {
+ goto done;
}
+ }
+ src = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = TclGetString(valuePtr);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- offset += (count + 7) / 8;
- break;
- }
- case 'h':
- case 'H': {
- char *dest;
- unsigned char *src;
- int i;
- static const char hexdigit[] = "0123456789abcdef";
-
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- count = (length - offset)*2;
- } else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset)*2) {
- goto done;
+ if (cmd == 'b') {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value >>= 1;
+ } else {
+ value = *src++;
}
+ *dest++ = (char) ((value & 1) ? '1' : '0');
}
- src = buffer + offset;
- valuePtr = Tcl_NewObj();
- Tcl_SetObjLength(valuePtr, count);
- dest = TclGetString(valuePtr);
-
- if (cmd == 'h') {
- for (i = 0; i < count; i++) {
- if (i % 2) {
- value >>= 4;
- } else {
- value = *src++;
- }
- *dest++ = hexdigit[value & 0xf];
- }
- } else {
- for (i = 0; i < count; i++) {
- if (i % 2) {
- value <<= 4;
- } else {
- value = *src++;
- }
- *dest++ = hexdigit[(value >> 4) & 0xf];
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value <<= 1;
+ } else {
+ value = *src++;
}
+ *dest++ = (char) ((value & 0x80) ? '1' : '0');
}
+ }
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
+ }
+ offset += (count + 7) / 8;
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *dest;
+ unsigned char *src;
+ static const char hexdigit[] = "0123456789abcdef";
+
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*2;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- offset += (count + 1) / 2;
- break;
- }
- case 'c':
- size = 1;
- goto scanNumber;
- case 't':
- case 's':
- case 'S':
- size = 2;
- goto scanNumber;
- case 'n':
- case 'i':
- case 'I':
- size = 4;
- goto scanNumber;
- case 'm':
- case 'w':
- case 'W':
- size = 8;
- goto scanNumber;
- case 'r':
- case 'R':
- case 'f':
- size = sizeof(float);
- goto scanNumber;
- case 'q':
- case 'Q':
- case 'd': {
- unsigned char *src;
-
- size = sizeof(double);
- /* fall through */
-
- scanNumber:
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
+ if (count > (length - offset)*2) {
+ goto done;
}
- if (count == BINARY_NOCOUNT) {
- if ((length - offset) < size) {
- goto done;
- }
- valuePtr = ScanNumber(buffer+offset, cmd, flags,
- &numberCachePtr);
- offset += size;
- } else {
- if (count == BINARY_ALL) {
- count = (length - offset) / size;
- }
- if ((length - offset) < (count * size)) {
- goto done;
+ }
+ src = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = TclGetString(valuePtr);
+
+ if (cmd == 'h') {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value >>= 4;
+ } else {
+ value = *src++;
}
- valuePtr = Tcl_NewObj();
- src = buffer+offset;
- for (i = 0; i < count; i++) {
- elementPtr = ScanNumber(src, cmd, flags,
- &numberCachePtr);
- src += size;
- Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
+ *dest++ = hexdigit[value & 0xf];
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value <<= 4;
+ } else {
+ value = *src++;
}
- offset += count*size;
+ *dest++ = hexdigit[(value >> 4) & 0xf];
}
+ }
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- break;
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
}
- case 'x':
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count == BINARY_ALL) || (count > (length - offset))) {
- offset = length;
- } else {
- offset += count;
- }
- break;
- case 'X':
- if (count == BINARY_NOCOUNT) {
- count = 1;
+ offset += (count + 1) / 2;
+ break;
+ }
+ case 'c':
+ size = 1;
+ goto scanNumber;
+ case 't':
+ case 's':
+ case 'S':
+ size = 2;
+ goto scanNumber;
+ case 'n':
+ case 'i':
+ case 'I':
+ size = 4;
+ goto scanNumber;
+ case 'm':
+ case 'w':
+ case 'W':
+ size = 8;
+ goto scanNumber;
+ case 'r':
+ case 'R':
+ case 'f':
+ size = sizeof(float);
+ goto scanNumber;
+ case 'q':
+ case 'Q':
+ case 'd': {
+ unsigned char *src;
+
+ size = sizeof(double);
+ /* fall through */
+
+ scanNumber:
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_NOCOUNT) {
+ if ((length - offset) < size) {
+ goto done;
}
- if ((count == BINARY_ALL) || (count > offset)) {
- offset = 0;
- } else {
- offset -= count;
+ valuePtr = ScanNumber(buffer+offset, cmd, flags,
+ &numberCachePtr);
+ offset += size;
+ } else {
+ if (count == BINARY_ALL) {
+ count = (length - offset) / size;
}
- break;
- case '@':
- if (count == BINARY_NOCOUNT) {
- DeleteScanNumberCache(numberCachePtr);
- goto badCount;
+ if ((length - offset) < (count * size)) {
+ goto done;
}
- if ((count == BINARY_ALL) || (count > length)) {
- offset = length;
- } else {
- offset = count;
+ valuePtr = Tcl_NewObj();
+ src = buffer + offset;
+ for (i = 0; i < count; i++) {
+ elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
+ src += size;
+ Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
- break;
- default:
+ offset += count * size;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
- errorString = str;
- goto badField;
+ return TCL_ERROR;
}
+ break;
+ }
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > (length - offset))) {
+ offset = length;
+ } else {
+ offset += count;
+ }
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > offset)) {
+ offset = 0;
+ } else {
+ offset -= count;
+ }
+ break;
+ case '@':
+ if (count == BINARY_NOCOUNT) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badCount;
+ }
+ if ((count == BINARY_ALL) || (count > length)) {
+ offset = length;
+ } else {
+ offset = count;
+ }
+ break;
+ default:
+ DeleteScanNumberCache(numberCachePtr);
+ errorString = str;
+ goto badField;
}
+ }
- /*
- * Set the result to the last position of the cursor.
- */
+ /*
+ * Set the result to the last position of the cursor.
+ */
- done:
- Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
- DeleteScanNumberCache(numberCachePtr);
- break;
- }
- }
- return TCL_OK;
+ done:
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
+ DeleteScanNumberCache(numberCachePtr);
- badValue:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected ", errorString,
- " string but got \"", errorValue, "\" instead", NULL);
- return TCL_ERROR;
+ return TCL_OK;
- badCount:
+ badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
- badIndex:
+ badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
- badField:
+ badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
@@ -1368,7 +1587,7 @@ Tcl_BinaryObjCmd(
return TCL_ERROR;
}
- error:
+ error:
Tcl_AppendResult(interp, errorString, NULL);
return TCL_ERROR;
}
@@ -1396,7 +1615,7 @@ Tcl_BinaryObjCmd(
static int
GetFormatSpec(
- char **formatPtr, /* Pointer to format string. */
+ const char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
int *countPtr, /* Pointer to repeat count value. */
int *flagsPtr) /* Pointer to field flags */
@@ -1425,15 +1644,15 @@ GetFormatSpec(
(*formatPtr)++;
if (**formatPtr == 'u') {
(*formatPtr)++;
- (*flagsPtr) |= BINARY_UNSIGNED;
+ *flagsPtr |= BINARY_UNSIGNED;
}
if (**formatPtr == '*') {
(*formatPtr)++;
- (*countPtr) = BINARY_ALL;
+ *countPtr = BINARY_ALL;
} else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
- (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
+ *countPtr = strtoul(*formatPtr, (char **) formatPtr, 10);
} else {
- (*countPtr) = BINARY_NOCOUNT;
+ *countPtr = BINARY_NOCOUNT;
}
return 1;
}
@@ -1556,11 +1775,11 @@ static void
CopyNumber(
const void *from, /* source */
void *to, /* destination */
- unsigned int length, /* Number of bytes to copy */
+ unsigned length, /* Number of bytes to copy */
int type) /* What type of thing are we copying? */
{
switch (NeedReversing(type)) {
- case 0:
+ case 0:
memcpy(to, from, length);
break;
case 1: {
@@ -1709,23 +1928,23 @@ FormatNumber(
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = (unsigned char) wvalue;
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 32);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 40);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 48);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 56);
} else {
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
- *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
- *(*cursorPtr)++ = (unsigned char) wvalue;
+ *(*cursorPtr)++ = UCHAR(wvalue >> 56);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 48);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 40);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 32);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -1739,15 +1958,15 @@ FormatNumber(
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = (unsigned char) value;
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
- *(*cursorPtr)++ = (unsigned char) (value >> 16);
- *(*cursorPtr)++ = (unsigned char) (value >> 24);
+ *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(value >> 16);
+ *(*cursorPtr)++ = UCHAR(value >> 24);
} else {
- *(*cursorPtr)++ = (unsigned char) (value >> 24);
- *(*cursorPtr)++ = (unsigned char) (value >> 16);
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
- *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = UCHAR(value >> 24);
+ *(*cursorPtr)++ = UCHAR(value >> 16);
+ *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(value);
}
return TCL_OK;
@@ -1761,11 +1980,11 @@ FormatNumber(
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = (unsigned char) value;
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(value >> 8);
} else {
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
- *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(value);
}
return TCL_OK;
@@ -1776,7 +1995,7 @@ FormatNumber(
if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
- *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = UCHAR(value);
return TCL_OK;
default:
@@ -1881,7 +2100,7 @@ ScanNumber(
value = (long) (buffer[3]
+ (buffer[2] << 8)
+ (buffer[1] << 16)
- + (((long)buffer[0]) << 24));
+ + (((long) buffer[0]) << 24));
}
/*
@@ -1894,9 +2113,9 @@ ScanNumber(
if (flags & BINARY_UNSIGNED) {
return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
}
- if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
- value -= (((unsigned int)1)<<31);
- value -= (((unsigned int)1)<<31);
+ if ((value & (((unsigned) 1)<<31)) && (value > 0)) {
+ value -= (((unsigned) 1)<<31);
+ value -= (((unsigned) 1)<<31);
}
returnNumericObject:
@@ -1907,15 +2126,15 @@ ScanNumber(
register Tcl_HashEntry *hPtr;
int isNew;
- hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
+ hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
- return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ return Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
Tcl_IncrRefCount(objPtr);
- Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+ Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
}
@@ -2042,9 +2261,488 @@ DeleteScanNumberCache(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * NOTES --
+ *
+ * Some measurements show that it is faster to use a table to to perform
+ * uuencode and base64 value encoding than to calculate the output (at
+ * least on intel P4 arch).
+ *
+ * Conversely using a lookup table for the decoding is slower than just
+ * calculating the values. We therefore use the fastest of each method.
+ *
+ * Presumably this has to do with the size of the tables. The base64
+ * decode table is 255 bytes while the encode table is only 65 bytes. The
+ * choice likely depends on CPU memory cache sizes.
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryEncodeHex --
+ *
+ * Implement the [binary encode hex] binary encoding. clientData must be
+ * a table to convert values to hexadecimal digits.
+ *
+ * Results:
+ * Interp result set to an encoded byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BinaryEncodeHex(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *resultObj = NULL;
+ unsigned char *data = NULL;
+ unsigned char *cursor = NULL;
+ const char *digits = clientData;
+ int offset = 0, count = 0;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ TclNewObj(resultObj);
+ 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)];
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryDecodeHex --
+ *
+ * Implement the [binary decode hex] binary encoding.
+ *
+ * Results:
+ * Interp result set to an decoded byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BinaryDecodeHex(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *resultObj = NULL;
+ unsigned char *data, *datastart, *dataend;
+ unsigned char *begin, *cursor, c;
+ int i, index, value, size, count = 0, cut = 0, strict = 0;
+ enum {OPT_STRICT };
+ static const char *const optStrings[] = { "-strict", NULL };
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-1; ++i) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
+ TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OPT_STRICT:
+ strict = 1;
+ break;
+ }
+ }
+
+ TclNewObj(resultObj);
+ datastart = data = (unsigned char *)
+ TclGetStringFromObj(objv[objc-1], &count);
+ dataend = data + count;
+ size = (count + 1) / 2;
+ begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
+ 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;
+ }
+ value <<= 4;
+ c -= '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
+ }
+ value |= (c & 0xf);
+ } else {
+ value <<= 4;
+ cut++;
+ }
+ }
+ *cursor++ = UCHAR(value);
+ value = 0;
+ }
+ if (cut > size) {
+ cut = size;
+ }
+ Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ badChar:
+ TclDecrRefCount(resultObj);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid hexadecimal digit \"%c\" at position %d",
+ c, (int) (data - datastart - 1)));
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryEncode64 --
+ *
+ * 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.
+ *
+ * Results:
+ * Interp result set to an encoded byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+#define OUTPUT(c) \
+ do { \
+ *cursor++ = (c); \
+ outindex++; \
+ if (maxlen > 0 && cursor != limit) { \
+ if (outindex == maxlen) { \
+ memcpy(cursor, wrapchar, wrapcharlen); \
+ cursor += wrapcharlen; \
+ outindex = 0; \
+ } \
+ } \
+ if (cursor > limit) { \
+ Tcl_Panic("limit hit"); \
+ } \
+ } while (0)
+
+static int
+BinaryEncode64(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *resultObj;
+ unsigned char *data, *cursor, *limit;
+ const char *digits = clientData;
+ int maxlen = 0;
+ const char *wrapchar = "\n";
+ int wrapcharlen = 1;
+ int offset, i, index, size, outindex = 0, count = 0;
+ 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], &maxlen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case OPT_WRAPCHAR:
+ wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen);
+ if (wrapcharlen == 0) {
+ maxlen = 0;
+ }
+ break;
+ }
+ }
+
+ resultObj = Tcl_NewObj();
+ data = Tcl_GetByteArrayFromObj(objv[objc-1], &count);
+ if (count > 0) {
+ size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
+ if (maxlen > 0 && size > maxlen) {
+ int adjusted = size + (wrapcharlen * (size / maxlen));
+
+ if (size % maxlen == 0) {
+ adjusted -= wrapcharlen;
+ }
+ size = adjusted;
+ }
+ cursor = Tcl_SetByteArrayLength(resultObj, size);
+ limit = cursor + size;
+ for (offset = 0; offset < count; offset+=3) {
+ unsigned char d[3] = {0, 0, 0};
+
+ 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)]);
+ if (offset+1 < count) {
+ OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
+ } else {
+ OUTPUT(digits[64]);
+ }
+ if (offset+2 < count) {
+ OUTPUT(digits[d[2] & 0x3f]);
+ } else {
+ OUTPUT(digits[64]);
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+#undef OUTPUT
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryDecodeUu --
+ *
+ * Decode a uuencoded string.
+ *
+ * Results:
+ * Interp result set to an byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BinaryDecodeUu(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ 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;
+ enum {OPT_STRICT };
+ static const char *const optStrings[] = { "-strict", NULL };
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-1; ++i) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
+ TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OPT_STRICT:
+ strict = 1;
+ break;
+ }
+ }
+
+ TclNewObj(resultObj);
+ datastart = data = (unsigned char *)
+ TclGetStringFromObj(objv[objc-1], &count);
+ dataend = data + count;
+ size = ((count + 3) & ~3) * 3 / 4;
+ begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
+ while (data < dataend) {
+ char d[4] = {0, 0, 0, 0};
+
+ 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;
+ }
+ i--;
+ continue;
+ }
+ } else {
+ cut++;
+ }
+ }
+ if (cut > 3) {
+ cut = 3;
+ }
+ *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;
+ }
+ Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ badUu:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid uuencode character \"%c\" at position %d",
+ c, (int) (data - datastart - 1)));
+ TclDecrRefCount(resultObj);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BinaryDecode64 --
+ *
+ * Decode a base64 encoded string.
+ *
+ * Results:
+ * Interp result set to an byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BinaryDecode64(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *resultObj = NULL;
+ unsigned char *data, *datastart, *dataend, c;
+ unsigned char *begin = NULL;
+ unsigned char *cursor = NULL;
+ int strict = 0;
+ int i, index, size, cut = 0, count = 0;
+ enum {OPT_STRICT };
+ static const char *const optStrings[] = { "-strict", NULL };
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-1; ++i) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
+ TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OPT_STRICT:
+ strict = 1;
+ break;
+ }
+ }
+
+ TclNewObj(resultObj);
+ datastart = data = (unsigned char *)
+ TclGetStringFromObj(objv[objc-1], &count);
+ dataend = data + count;
+ size = ((count + 3) & ~3) * 3 / 4;
+ begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
+ while (data < dataend) {
+ unsigned long value = 0;
+
+ for (i=0 ; i<4 ; i++) {
+ if (data < dataend) {
+ c = *data++;
+
+ if (c >= 'A' && c <= 'Z') {
+ value = (value << 6) | ((c - 'A') & 0x3f);
+ } else if (c >= 'a' && c <= 'z') {
+ value = (value << 6) | ((c - 'a' + 26) & 0x3f);
+ } else if (c >= '0' && c <= '9') {
+ value = (value << 6) | ((c - '0' + 52) & 0x3f);
+ } else if (c == '+') {
+ value = (value << 6) | 0x3e;
+ } else if (c == '/') {
+ value = (value << 6) | 0x3f;
+ } else if (c == '=') {
+ value <<= 6;
+ if (cut < 2) {
+ cut++;
+ }
+ } else {
+ if (strict || !isspace(c)) {
+ goto bad64;
+ }
+ i--;
+ continue;
+ }
+ } else {
+ value <<= 6;
+ cut++;
+ }
+ }
+ *cursor++ = UCHAR((value >> 16) & 0xff);
+ *cursor++ = UCHAR((value >> 8) & 0xff);
+ *cursor++ = UCHAR(value & 0xff);
+ }
+ if (cut > size) {
+ cut = size;
+ }
+ Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ bad64:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid base64 character \"%c\" at position %d",
+ (char) c, (int) (data - datastart - 1)));
+ TclDecrRefCount(resultObj);
+ return TCL_ERROR;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
+
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 9d3d6d7..056841d 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -20,6 +20,12 @@
#define FALSE 0
#define TRUE 1
+#undef Tcl_Alloc
+#undef Tcl_Free
+#undef Tcl_Realloc
+#undef Tcl_AttemptAlloc
+#undef Tcl_AttemptRealloc
+
#ifdef TCL_MEM_DEBUG
/*
@@ -30,12 +36,12 @@
typedef struct MemTag {
int refCount; /* Number of mem_headers referencing this
* tag. */
- char string[4]; /* Actual size of string will be as large as
+ char string[1]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
-#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)
+#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString))
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,7 +58,7 @@ struct mem_header {
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
- CONST char *file;
+ const char *file;
long length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
@@ -126,11 +132,11 @@ static int ckallocInit = 0;
*/
static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST char *argv[]);
+ int argc, const char *argv[]);
static int MemoryCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST char *argv[]);
+ int argc, const char *argv[]);
static void ValidateMemory(struct mem_header *memHeaderP,
- CONST char *file, int line, int nukeGuards);
+ const char *file, int line, int nukeGuards);
/*
*----------------------------------------------------------------------
@@ -183,7 +189,7 @@ TclDumpMemoryInfo(ClientData clientData, int flags)
maximum_malloc_packets,
maximum_bytes_malloced);
if (flags == 0) {
- fprintf((FILE *)clientData, buf);
+ fprintf((FILE *)clientData, "%s", buf);
} else {
/* Assume objPtr to append to */
Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1);
@@ -212,7 +218,7 @@ static void
ValidateMemory(
struct mem_header *memHeaderP,
/* Memory chunk to validate */
- CONST char *file, /* File containing the call to
+ const char *file, /* File containing the call to
* Tcl_ValidateAllMemory */
int line, /* Line number of call to
* Tcl_ValidateAllMemory */
@@ -238,7 +244,7 @@ ValidateMemory(
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "low guard failed at %lx, %s %d\n",
- (long unsigned int) memHeaderP->body, file, line);
+ (long unsigned) memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
@@ -260,7 +266,7 @@ ValidateMemory(
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "high guard failed at %lx, %s %d\n",
- (long unsigned int) memHeaderP->body, file, line);
+ (long unsigned) memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
@@ -293,7 +299,7 @@ ValidateMemory(
void
Tcl_ValidateAllMemory(
- CONST char *file, /* File from which Tcl_ValidateAllMemory was
+ const char *file, /* File from which Tcl_ValidateAllMemory was
* called. */
int line) /* Line number of call to
* Tcl_ValidateAllMemory */
@@ -327,7 +333,7 @@ Tcl_ValidateAllMemory(
int
Tcl_DumpActiveMemory(
- CONST char *fileName) /* Name of the file to write info to */
+ const char *fileName) /* Name of the file to write info to */
{
FILE *fileP;
struct mem_header *memScanP;
@@ -344,10 +350,10 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
- address = &memScanP->body [0];
+ address = &memScanP->body[0];
fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
- (long unsigned int) address,
- (long unsigned int) address + memScanP->length - 1,
+ (long unsigned) address,
+ (long unsigned) address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
@@ -381,7 +387,7 @@ Tcl_DumpActiveMemory(
char *
Tcl_DbCkalloc(
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
struct mem_header *result = NULL;
@@ -451,11 +457,7 @@ Tcl_DbCkalloc(
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- fprintf(stderr,"reached malloc break limit (%d)\n",
- total_mallocs);
- fprintf(stderr, "program will now enter C debugger\n");
- (void) fflush(stderr);
- abort();
+ Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
}
current_malloc_packets++;
@@ -475,7 +477,7 @@ Tcl_DbCkalloc(
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
struct mem_header *result = NULL;
@@ -544,11 +546,7 @@ Tcl_AttemptDbCkalloc(
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- fprintf(stderr,"reached malloc break limit (%d)\n",
- total_mallocs);
- fprintf(stderr, "program will now enter C debugger\n");
- (void) fflush(stderr);
- abort();
+ Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
}
current_malloc_packets++;
@@ -583,16 +581,16 @@ Tcl_AttemptDbCkalloc(
*----------------------------------------------------------------------
*/
-int
+void
Tcl_DbCkfree(
char *ptr,
- CONST char *file,
+ const char *file,
int line)
{
struct mem_header *memp;
if (ptr == NULL) {
- return 0;
+ return;
}
/*
@@ -646,8 +644,6 @@ Tcl_DbCkfree(
}
TclpFree((char *) memp);
Tcl_MutexUnlock(ckallocMutexPtr);
-
- return 0;
}
/*
@@ -667,7 +663,7 @@ char *
Tcl_DbCkrealloc(
char *ptr,
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *newPtr;
@@ -698,7 +694,7 @@ char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *newPtr;
@@ -746,12 +742,6 @@ Tcl_AttemptDbCkrealloc(
*----------------------------------------------------------------------
*/
-#undef Tcl_Alloc
-#undef Tcl_Free
-#undef Tcl_Realloc
-#undef Tcl_AttemptAlloc
-#undef Tcl_AttemptRealloc
-
char *
Tcl_Alloc(
unsigned int size)
@@ -816,9 +806,9 @@ MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int argc,
- CONST char *argv[])
+ const char *argv[])
{
- CONST char *fileName;
+ const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
@@ -840,7 +830,7 @@ MemoryCmd(
if (fileName == NULL) {
return TCL_ERROR;
}
- result = Tcl_DumpActiveMemory (fileName);
+ result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
@@ -950,7 +940,7 @@ MemoryCmd(
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be active, break_on_malloc, info, init, onexit, "
+ "\": should be active, break_on_malloc, info, init, objs, onexit, "
"tag, trace, trace_on_at_malloc, or validate", NULL);
return TCL_ERROR;
@@ -988,7 +978,7 @@ CheckmemCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for evaluation. */
int argc, /* Number of arguments. */
- CONST char *argv[]) /* String values of arguments. */
+ const char *argv[]) /* String values of arguments. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -1022,8 +1012,8 @@ Tcl_InitMemory(
* added */
{
TclInitDbCkalloc();
- Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, NULL);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
+ Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
@@ -1074,7 +1064,7 @@ Tcl_Alloc(
char *
Tcl_DbCkalloc(
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *result;
@@ -1112,7 +1102,7 @@ Tcl_AttemptAlloc(
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *result;
@@ -1151,7 +1141,7 @@ char *
Tcl_DbCkrealloc(
char *ptr,
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *result;
@@ -1191,7 +1181,7 @@ char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
- CONST char *file,
+ const char *file,
int line)
{
char *result;
@@ -1219,14 +1209,13 @@ Tcl_Free(
TclpFree(ptr);
}
-int
+void
Tcl_DbCkfree(
char *ptr,
- CONST char *file,
+ const char *file,
int line)
{
TclpFree(ptr);
- return 0;
}
/*
@@ -1248,14 +1237,14 @@ Tcl_InitMemory(
int
Tcl_DumpActiveMemory(
- CONST char *fileName)
+ const char *fileName)
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
- CONST char *file,
+ const char *file,
int line)
{
}
@@ -1318,5 +1307,7 @@ TclFinalizeMemorySubsystem(void)
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 5b95ae6..7fa4017 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -7,7 +7,7 @@
*
* Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,12 +31,12 @@
#define SECONDS_PER_DAY 86400
#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
* SECONDS_PER_DAY)
-#define FOUR_CENTURIES 146097 /* days */
+#define FOUR_CENTURIES 146097 /* days */
#define JDAY_1_JAN_1_CE_JULIAN 1721424
#define JDAY_1_JAN_1_CE_GREGORIAN 1721426
-#define ONE_CENTURY_GREGORIAN 36524 /* days */
-#define FOUR_YEARS 1461 /* days */
-#define ONE_YEAR 365 /* days */
+#define ONE_CENTURY_GREGORIAN 36524 /* days */
+#define FOUR_YEARS 1461 /* days */
+#define ONE_YEAR 365 /* days */
/*
* Table of the days in each month, leap and common years
@@ -58,7 +58,7 @@ static const int daysInPriorMonths[2][13] = {
typedef enum ClockLiteral {
LIT__NIL,
LIT__DEFAULT_FORMAT,
- LIT_BCE, LIT_C,
+ LIT_BCE, LIT_C,
LIT_CANNOT_USE_GMT_AND_TIMEZONE,
LIT_CE,
LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR,
@@ -74,7 +74,7 @@ typedef enum ClockLiteral {
static const char *const literals[] = {
"",
"%a %b %d %H:%M:%S %Z %Y",
- "BCE", "C",
+ "BCE", "C",
"cannot use -gmt and -timezone in same call",
"CE",
"dayOfMonth", "dayOfWeek", "dayOfYear",
@@ -92,8 +92,8 @@ static const char *const literals[] = {
*/
typedef struct ClockClientData {
- int refCount; /* Number of live references */
- Tcl_Obj** literals; /* Pool of object literals */
+ int refCount; /* Number of live references. */
+ Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
/*
@@ -107,7 +107,7 @@ typedef struct TclDateFields {
* from the Posix epoch */
int tzOffset; /* Time zone offset in seconds east of
* Greenwich */
- Tcl_Obj* tzName; /* Time zone name */
+ Tcl_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
enum {BCE=1, CE=0} era; /* Era */
int gregorian; /* Flag == 1 if the date is Gregorian */
@@ -119,7 +119,7 @@ typedef struct TclDateFields {
int iso8601Week; /* ISO8601 week number */
int dayOfWeek; /* Day of the week */
} TclDateFields;
-static const char* eras[] = { "CE", "BCE", NULL };
+static const char *const eras[] = { "CE", "BCE", NULL };
/*
* Thread specific data block holding a 'struct tm' for the 'gmtime' and
@@ -139,26 +139,26 @@ TCL_DECLARE_MUTEX(clockMutex)
* Function prototypes for local procedures in this file:
*/
-static int ConvertUTCToLocal(Tcl_Interp*,
- TclDateFields*, Tcl_Obj*, int);
-static int ConvertUTCToLocalUsingTable(Tcl_Interp*,
- TclDateFields*, int, Tcl_Obj *const[]);
-static int ConvertUTCToLocalUsingC(Tcl_Interp*,
- TclDateFields*, int);
-static int ConvertLocalToUTC(Tcl_Interp*,
- TclDateFields*, Tcl_Obj*, int);
-static int ConvertLocalToUTCUsingTable(Tcl_Interp*,
- TclDateFields*, int, Tcl_Obj *const[]);
-static int ConvertLocalToUTCUsingC(Tcl_Interp*,
- TclDateFields*, int);
-static Tcl_Obj* LookupLastTransition(Tcl_Interp*, Tcl_WideInt,
+static int ConvertUTCToLocal(Tcl_Interp *,
+ TclDateFields *, Tcl_Obj *, int);
+static int ConvertUTCToLocalUsingTable(Tcl_Interp *,
+ TclDateFields *, int, Tcl_Obj *const[]);
+static int ConvertUTCToLocalUsingC(Tcl_Interp *,
+ TclDateFields *, int);
+static int ConvertLocalToUTC(Tcl_Interp *,
+ TclDateFields *, Tcl_Obj *, int);
+static int ConvertLocalToUTCUsingTable(Tcl_Interp *,
+ TclDateFields *, int, Tcl_Obj *const[]);
+static int ConvertLocalToUTCUsingC(Tcl_Interp *,
+ TclDateFields *, int);
+static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
int, Tcl_Obj *const *);
-static void GetYearWeekDay(TclDateFields*, int);
-static void GetGregorianEraYearDay(TclDateFields*, int);
-static void GetMonthDay(TclDateFields*);
-static void GetJulianDayFromEraYearWeekDay(TclDateFields*, int);
-static void GetJulianDayFromEraYearMonthDay(TclDateFields*, int);
-static int IsGregorianLeapYear(TclDateFields*);
+static void GetYearWeekDay(TclDateFields *, int);
+static void GetGregorianEraYearDay(TclDateFields *, int);
+static void GetMonthDay(TclDateFields *);
+static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int);
+static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int);
+static int IsGregorianLeapYear(TclDateFields *);
static int WeekdayOnOrBefore(int, int);
static int ClockClicksObjCmd(
ClientData clientData, Tcl_Interp *interp,
@@ -185,7 +185,7 @@ static int ClockMillisecondsObjCmd(
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int ClockParseformatargsObjCmd(
- ClientData clientData, Tcl_Interp* interp,
+ ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int ClockSecondsObjCmd(
ClientData clientData, Tcl_Interp *interp,
@@ -219,7 +219,7 @@ static const struct ClockCommand clockCommands[] = {
{ "GetJulianDayFromEraYearMonthDay",
ClockGetjuliandayfromerayearmonthdayObjCmd },
{ "GetJulianDayFromEraYearWeekDay",
- ClockGetjuliandayfromerayearweekdayObjCmd },
+ ClockGetjuliandayfromerayearweekdayObjCmd },
{ "ParseFormatArgs", ClockParseformatargsObjCmd },
{ NULL, NULL }
};
@@ -249,7 +249,7 @@ TclClockInit(
const struct ClockCommand *clockCmdPtr;
char cmdName[50]; /* Buffer large enough to hold the string
*::tcl::clock::GetJulianDayFromEraYearMonthDay
- * plus a terminating NULL. */
+ * plus a terminating NUL. */
ClockClientData *data;
int i;
@@ -266,9 +266,9 @@ TclClockInit(
* Create the client data, which is a refcounted literal pool.
*/
- data = (ClockClientData *) ckalloc(sizeof(ClockClientData));
+ data = ckalloc(sizeof(ClockClientData));
data->refCount = 0;
- data->literals = (Tcl_Obj**) ckalloc(LIT__END * sizeof(Tcl_Obj*));
+ data->literals = ckalloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
data->literals[i] = Tcl_NewStringObj(literals[i], -1);
Tcl_IncrRefCount(data->literals[i]);
@@ -278,8 +278,8 @@ TclClockInit(
* Install the commands.
*/
- strcpy(cmdName, "::tcl::clock::");
#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
+ memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
data->refCount++;
@@ -317,15 +317,15 @@ TclClockInit(
static int
ClockConvertlocaltoutcObjCmd(
- ClientData clientData, /* Client data */
- Tcl_Interp* interp, /* Tcl interpreter */
+ ClientData clientData, /* Client data */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
- ClockClientData* data = (ClockClientData*) clientData;
- Tcl_Obj* const * literals = data->literals;
- Tcl_Obj* secondsObj;
- Tcl_Obj* dict;
+ ClockClientData *data = clientData;
+ Tcl_Obj *const *literals = data->literals;
+ Tcl_Obj *secondsObj;
+ Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
@@ -341,16 +341,16 @@ ClockConvertlocaltoutcObjCmd(
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS],
- &secondsObj)!= TCL_OK) {
+ &secondsObj)!= TCL_OK) {
return TCL_ERROR;
}
if (secondsObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
- "found in dictionary", -1));
+ "found in dictionary", -1));
return TCL_ERROR;
}
if ((Tcl_GetWideIntFromObj(interp, secondsObj,
- &(fields.localSeconds)) != TCL_OK)
+ &fields.localSeconds) != TCL_OK)
|| (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
|| ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
return TCL_ERROR;
@@ -390,16 +390,16 @@ ClockConvertlocaltoutcObjCmd(
*
* Parameters:
* seconds - Time expressed in seconds from the Posix epoch.
- * tzdata - Time zone data of the time zone in which time is to
- * be expressed.
+ * tzdata - Time zone data of the time zone in which time is to be
+ * expressed.
* changeover - Julian Day Number at which the current locale adopted
* the Gregorian calendar
*
* Results:
* Returns a dictonary populated with the fields:
* seconds - Seconds from the Posix epoch
- * localSeconds - Nominal seconds from the Posix epoch in
- * the local time zone.
+ * localSeconds - Nominal seconds from the Posix epoch in the
+ * local time zone.
* tzOffset - Time zone offset in seconds east of Greenwich
* tzName - Time zone name
* julianDay - Julian Day Number in the local time zone
@@ -410,14 +410,14 @@ ClockConvertlocaltoutcObjCmd(
int
ClockGetdatefieldsObjCmd(
ClientData clientData, /* Opaque pointer to literal pool, etc. */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
- Tcl_Obj* dict;
- ClockClientData* data = (ClockClientData*) clientData;
- Tcl_Obj* const * literals = data->literals;
+ Tcl_Obj *dict;
+ ClockClientData *data = clientData;
+ Tcl_Obj *const *literals = data->literals;
int changeover;
/*
@@ -428,14 +428,14 @@ ClockGetdatefieldsObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover");
return TCL_ERROR;
}
- if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK
+ if (Tcl_GetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK
|| TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- /*
- * fields.seconds could be an unsigned number that overflowed. Make
- * sure that it isn't.
+ /*
+ * fields.seconds could be an unsigned number that overflowed. Make sure
+ * that it isn't.
*/
if (objv[1]->typePtr == &tclBignumType) {
@@ -522,17 +522,17 @@ ClockGetdatefieldsObjCmd(
*/
static int
-ClockGetjuliandayfromerayearmonthdayObjCmd (
+ClockGetjuliandayfromerayearmonthdayObjCmd(
ClientData clientData, /* Opaque pointer to literal pool, etc. */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
- Tcl_Obj* dict;
- ClockClientData* data = (ClockClientData*) clientData;
- Tcl_Obj* const * literals = data->literals;
- Tcl_Obj* fieldPtr;
+ Tcl_Obj *dict;
+ ClockClientData *data = clientData;
+ Tcl_Obj *const *literals = data->literals;
+ Tcl_Obj *fieldPtr;
int changeover;
int copied = 0;
int status;
@@ -552,14 +552,13 @@ ClockGetjuliandayfromerayearmonthdayObjCmd (
&era) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr,
- &(fields.dayOfMonth)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
@@ -613,17 +612,17 @@ ClockGetjuliandayfromerayearmonthdayObjCmd (
*/
static int
-ClockGetjuliandayfromerayearweekdayObjCmd (
+ClockGetjuliandayfromerayearweekdayObjCmd(
ClientData clientData, /* Opaque pointer to literal pool, etc. */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
- Tcl_Obj* dict;
- ClockClientData* data = (ClockClientData*) clientData;
- Tcl_Obj* const * literals = data->literals;
- Tcl_Obj* fieldPtr;
+ Tcl_Obj *dict;
+ ClockClientData *data = clientData;
+ Tcl_Obj *const *literals = data->literals;
+ Tcl_Obj *fieldPtr;
int changeover;
int copied = 0;
int status;
@@ -643,16 +642,13 @@ ClockGetjuliandayfromerayearweekdayObjCmd (
&era) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr,
- &(fields.iso8601Year)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Year)!=TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr,
- &(fields.iso8601Week)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Week)!=TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK],
&fieldPtr) != TCL_OK
- || TclGetIntFromObj(interp, fieldPtr,
- &(fields.dayOfWeek)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfWeek) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
@@ -704,13 +700,13 @@ ClockGetjuliandayfromerayearweekdayObjCmd (
static int
ConvertLocalToUTC(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Fields of the time */
- Tcl_Obj* tzdata, /* Time zone data */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Fields of the time */
+ Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
int rowc; /* Number of rows in tzdata */
- Tcl_Obj** rowv; /* Pointers to the rows */
+ Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
@@ -752,14 +748,14 @@ ConvertLocalToUTC(
static int
ConvertLocalToUTCUsingTable(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Time to convert, with 'seconds' filled in */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int rowc, /* Number of points at which time changes */
Tcl_Obj *const rowv[]) /* Points at which time changes */
{
- Tcl_Obj* row;
+ Tcl_Obj *row;
int cellc;
- Tcl_Obj** cellv;
+ Tcl_Obj **cellv;
int have[8];
int nHave = 0;
int i;
@@ -784,7 +780,7 @@ ConvertLocalToUTCUsingTable(
|| TclListObjGetElements(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
- &(fields->tzOffset)) != TCL_OK) {
+ &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
found = 0;
@@ -798,8 +794,7 @@ ConvertLocalToUTCUsingTable(
if (nHave == 8) {
Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
}
- have[nHave] = fields->tzOffset;
- ++nHave;
+ have[nHave++] = fields->tzOffset;
}
fields->seconds = fields->localSeconds - fields->tzOffset;
}
@@ -828,8 +823,8 @@ ConvertLocalToUTCUsingTable(
static int
ConvertLocalToUTCUsingC(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Time to convert, with 'seconds' filled in */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
struct tm timeVal;
@@ -846,7 +841,7 @@ ConvertLocalToUTCUsingC(
secondOfDay = (int)(jsec % SECONDS_PER_DAY);
if (secondOfDay < 0) {
secondOfDay += SECONDS_PER_DAY;
- --fields->julianDay;
+ fields->julianDay--;
}
GetGregorianEraYearDay(fields, changeover);
GetMonthDay(fields);
@@ -908,13 +903,13 @@ ConvertLocalToUTCUsingC(
static int
ConvertUTCToLocal(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Fields of the time */
- Tcl_Obj* tzdata, /* Time zone data */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Fields of the time */
+ Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
int rowc; /* Number of rows in tzdata */
- Tcl_Obj** rowv; /* Pointers to the rows */
+ Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
@@ -956,15 +951,15 @@ ConvertUTCToLocal(
static int
ConvertUTCToLocalUsingTable(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Fields of the date */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Fields of the date */
int rowc, /* Number of rows in the conversion table
* (>= 1) */
Tcl_Obj *const rowv[]) /* Rows of the conversion table */
{
- Tcl_Obj* row; /* Row containing the current information */
+ Tcl_Obj *row; /* Row containing the current information */
int cellc; /* Count of cells in the row (must be 4) */
- Tcl_Obj** cellv; /* Pointers to the cells */
+ Tcl_Obj **cellv; /* Pointers to the cells */
/*
* Look up the nearest transition time.
@@ -973,7 +968,7 @@ ConvertUTCToLocalUsingTable(
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
- TclGetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) {
+ TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
@@ -1008,12 +1003,12 @@ ConvertUTCToLocalUsingTable(
static int
ConvertUTCToLocalUsingC(
- Tcl_Interp* interp, /* Tcl interpreter */
- TclDateFields* fields, /* Time to convert, with 'seconds' filled in */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
- struct tm* timeVal; /* Time after conversion */
+ struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
char buffer[8]; /* Buffer for time zone name */
@@ -1094,16 +1089,16 @@ ConvertUTCToLocalUsingC(
*----------------------------------------------------------------------
*/
-static Tcl_Obj*
+static Tcl_Obj *
LookupLastTransition(
- Tcl_Interp* interp, /* Interpreter for error messages */
+ Tcl_Interp *interp, /* Interpreter for error messages */
Tcl_WideInt tick, /* Time from the epoch */
int rowc, /* Number of rows of tzdata */
Tcl_Obj *const *rowv) /* Rows in tzdata */
{
int l;
int u;
- Tcl_Obj* compObj;
+ Tcl_Obj *compObj;
Tcl_WideInt compVal;
/*
@@ -1166,7 +1161,7 @@ LookupLastTransition(
static void
GetYearWeekDay(
- TclDateFields* fields, /* Date to convert, must have 'julianDay' */
+ TclDateFields *fields, /* Date to convert, must have 'julianDay' */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
@@ -1233,7 +1228,7 @@ GetYearWeekDay(
static void
GetGregorianEraYearDay(
- TclDateFields* fields, /* Date fields containing 'julianDay' */
+ TclDateFields *fields, /* Date fields containing 'julianDay' */
int changeover) /* Gregorian transition date */
{
int jday = fields->julianDay;
@@ -1259,7 +1254,7 @@ GetGregorianEraYearDay(
day %= FOUR_CENTURIES;
if (day < 0) {
day += FOUR_CENTURIES;
- --n;
+ n--;
}
year += 400 * n;
@@ -1279,7 +1274,6 @@ GetGregorianEraYearDay(
day += ONE_CENTURY_GREGORIAN;
}
year += 100 * n;
-
} else {
/*
* Julian calendar.
@@ -1288,7 +1282,6 @@ GetGregorianEraYearDay(
fields->gregorian = 0;
year = 1;
day = jday - JDAY_1_JAN_1_CE_JULIAN;
-
}
/*
@@ -1299,7 +1292,7 @@ GetGregorianEraYearDay(
day %= FOUR_YEARS;
if (day < 0) {
day += FOUR_YEARS;
- --n;
+ n--;
}
year += 4 * n;
@@ -1351,11 +1344,11 @@ GetGregorianEraYearDay(
static void
GetMonthDay(
- TclDateFields* fields) /* Date to convert */
+ TclDateFields *fields) /* Date to convert */
{
int day = fields->dayOfYear;
int month;
- const int* h = hath[IsGregorianLeapYear(fields)];
+ const int *h = hath[IsGregorianLeapYear(fields)];
for (month = 0; month < 12 && day > h[month]; ++month) {
day -= h[month];
@@ -1383,18 +1376,18 @@ GetMonthDay(
static void
GetJulianDayFromEraYearWeekDay(
- TclDateFields* fields, /* Date to convert */
+ TclDateFields *fields, /* Date to convert */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
int firstMonday; /* Julian day number of week 1, day 1 in the
* given year */
+ TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
- TclDateFields firstWeek;
firstWeek.era = fields->era;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
@@ -1434,13 +1427,10 @@ GetJulianDayFromEraYearWeekDay(
static void
GetJulianDayFromEraYearMonthDay(
- TclDateFields* fields, /* Date to convert */
+ TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
- int year; int ym1;
- int month; int mm1;
- int q; int r;
- int ym1o4; int ym1o100; int ym1o400;
+ int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
if (fields->era == BCE) {
year = 1 - fields->year;
@@ -1483,15 +1473,15 @@ GetJulianDayFromEraYearMonthDay(
ym1o4 = ym1 / 4;
if (ym1 % 4 < 0) {
- --ym1o4;
+ ym1o4--;
}
ym1o100 = ym1 / 100;
if (ym1 % 100 < 0) {
- --ym1o100;
+ ym1o100--;
}
ym1o400 = ym1 / 400;
if (ym1 % 400 < 0) {
- --ym1o400;
+ ym1o400--;
}
fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1
+ fields->dayOfMonth
@@ -1511,8 +1501,8 @@ GetJulianDayFromEraYearMonthDay(
fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1
+ fields->dayOfMonth
+ daysInPriorMonths[year%4 == 0][month - 1]
- + (ONE_YEAR * ym1)
- + ym1o4;
+ + (365 * ym1)
+ + ym1o4;
}
}
@@ -1532,7 +1522,7 @@ GetJulianDayFromEraYearMonthDay(
static int
IsGregorianLeapYear(
- TclDateFields* fields) /* Date to test */
+ TclDateFields *fields) /* Date to test */
{
int year;
@@ -1604,12 +1594,12 @@ WeekdayOnOrBefore(
int
ClockGetenvObjCmd(
ClientData clientData,
- Tcl_Interp* interp,
+ Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- const char* varName;
- const char* varValue;
+ const char *varName;
+ const char *varValue;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
@@ -1650,8 +1640,7 @@ ThreadSafeLocalTime(
* Get a thread-local buffer to hold the returned time.
*/
- struct tm *tmPtr = (struct tm *)
- Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
+ struct tm *tmPtr = Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
@@ -1662,10 +1651,9 @@ ThreadSafeLocalTime(
if (sysTmPtr == NULL) {
Tcl_MutexUnlock(&clockMutex);
return NULL;
- } else {
- memcpy((void *) tmPtr, (void *) localtime(timePtr), sizeof(struct tm));
- Tcl_MutexUnlock(&clockMutex);
}
+ memcpy(tmPtr, localtime(timePtr), sizeof(struct tm));
+ Tcl_MutexUnlock(&clockMutex);
#endif
return tmPtr;
}
@@ -1691,55 +1679,53 @@ ThreadSafeLocalTime(
int
ClockClicksObjCmd(
ClientData clientData, /* Client data is unused */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
- Tcl_Obj* const* objv) /* Parameter values */
+ Tcl_Obj *const *objv) /* Parameter values */
{
- static const char *clicksSwitches[] = {
+ static const char *const clicksSwitches[] = {
"-milliseconds", "-microseconds", NULL
};
enum ClicksSwitch {
- CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
+ CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
};
int index = CLICKS_NATIVE;
Tcl_Time now;
+ Tcl_WideInt clicks = 0;
switch (objc) {
case 1:
break;
case 2:
- if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
+ if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
break;
default:
- Tcl_WrongNumArgs(interp, 1, objv, "?option?");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
return TCL_ERROR;
}
switch (index) {
case CLICKS_MILLIS:
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
- now.sec * 1000 + now.usec / 1000));
+ clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000;
break;
- case CLICKS_NATIVE: {
-#ifndef TCL_WIDE_CLICKS
- unsigned long clicks = TclpGetClicks();
+ case CLICKS_NATIVE:
+#ifdef TCL_WIDE_CLICKS
+ clicks = TclpGetWideClicks();
#else
- Tcl_WideInt clicks = TclpGetWideClicks();
+ clicks = (Tcl_WideInt) TclpGetClicks();
#endif
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) clicks));
break;
- }
case CLICKS_MICROS:
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
- ((Tcl_WideInt) now.sec * 1000000) + now.usec));
+ clicks = ((Tcl_WideInt) now.sec * 1000000) + now.usec;
break;
}
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks));
return TCL_OK;
}
@@ -1764,9 +1750,9 @@ ClockClicksObjCmd(
int
ClockMillisecondsObjCmd(
ClientData clientData, /* Client data is unused */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
- Tcl_Obj* const* objv) /* Parameter values */
+ Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
@@ -1775,7 +1761,7 @@ ClockMillisecondsObjCmd(
return TCL_ERROR;
}
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt)
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
now.sec * 1000 + now.usec / 1000));
return TCL_OK;
}
@@ -1801,9 +1787,9 @@ ClockMillisecondsObjCmd(
int
ClockMicrosecondsObjCmd(
ClientData clientData, /* Client data is unused */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
- Tcl_Obj* const* objv) /* Parameter values */
+ Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
@@ -1825,12 +1811,12 @@ ClockMicrosecondsObjCmd(
* Parses the arguments for [clock format].
*
* Results:
- * Returns a standard Tcl result, whose value is a four-element
- * list comprising the time format, the locale, and the timezone.
+ * Returns a standard Tcl result, whose value is a four-element list
+ * comprising the time format, the locale, and the timezone.
*
* This function exists because the loop that parses the [clock format]
- * options is a known performance "hot spot", and is implemented in an
- * effort to speed that particular code up.
+ * options is a known performance "hot spot", and is implemented in an effort
+ * to speed that particular code up.
*
*-----------------------------------------------------------------------------
*/
@@ -1838,56 +1824,53 @@ ClockMicrosecondsObjCmd(
static int
ClockParseformatargsObjCmd(
ClientData clientData, /* Client data containing literal pool */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
- Tcl_Obj *const objv[] /* Parameter vector */
-) {
-
- ClockClientData* dataPtr = (ClockClientData*) clientData;
- Tcl_Obj** litPtr = dataPtr->literals;
-
- /* Format, locale and timezone */
-
- Tcl_Obj* results[3];
+ Tcl_Obj *const objv[]) /* Parameter vector */
+{
+ ClockClientData *dataPtr = clientData;
+ Tcl_Obj **litPtr = dataPtr->literals;
+ Tcl_Obj *results[3]; /* Format, locale and timezone */
#define formatObj results[0]
#define localeObj results[1]
#define timezoneObj results[2]
int gmtFlag = 0;
-
- /* Command line options expected */
-
- static const char* options[] = {
- "-format", "-gmt", "-locale",
- "-timezone", NULL };
+ static const char *const options[] = { /* Command line options expected */
+ "-format", "-gmt", "-locale",
+ "-timezone", NULL };
enum optionInd {
CLOCK_FORMAT_FORMAT, CLOCK_FORMAT_GMT, CLOCK_FORMAT_LOCALE,
- CLOCK_FORMAT_TIMEZONE
+ CLOCK_FORMAT_TIMEZONE
};
- int optionIndex; /* Index of an option */
- int saw = 0; /* Flag == 1 if option was seen already */
- Tcl_WideInt clockVal; /* Clock value - just used to parse */
+ int optionIndex; /* Index of an option. */
+ int saw = 0; /* Flag == 1 if option was seen already. */
+ Tcl_WideInt clockVal; /* Clock value - just used to parse. */
int i;
- /* Args consist of a time followed by keyword-value pairs */
+ /*
+ * Args consist of a time followed by keyword-value pairs.
+ */
if (objc < 2 || (objc % 2) != 0) {
Tcl_WrongNumArgs(interp, 0, objv,
- "clock format clockval ?-format string? "
- "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
+ "clock format clockval ?-format string? "
+ "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL);
return TCL_ERROR;
}
- /* Extract values for the keywords */
+ /*
+ * Extract values for the keywords.
+ */
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0,
- &optionIndex) != TCL_OK) {
+ &optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badSwitch",
- Tcl_GetString(objv[i]), NULL);
+ Tcl_GetString(objv[i]), NULL);
return TCL_ERROR;
}
switch (optionIndex) {
@@ -1895,7 +1878,7 @@ ClockParseformatargsObjCmd(
formatObj = objv[i+1];
break;
case CLOCK_FORMAT_GMT:
- if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK) {
+ if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK){
return TCL_ERROR;
}
break;
@@ -1906,16 +1889,18 @@ ClockParseformatargsObjCmd(
timezoneObj = objv[i+1];
break;
}
- saw |= (1 << optionIndex);
+ saw |= 1 << optionIndex;
}
- /* Check options */
+ /*
+ * Check options.
+ */
if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
return TCL_ERROR;
}
if ((saw & (1 << CLOCK_FORMAT_GMT))
- && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
+ && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]);
Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL);
return TCL_ERROR;
@@ -1924,7 +1909,9 @@ ClockParseformatargsObjCmd(
timezoneObj = litPtr[LIT_GMT];
}
- /* Return options as a list */
+ /*
+ * Return options as a list.
+ */
Tcl_SetObjResult(interp, Tcl_NewListObj(3, results));
return TCL_OK;
@@ -1932,7 +1919,6 @@ ClockParseformatargsObjCmd(
#undef timezoneObj
#undef localeObj
#undef formatObj
-
}
/*----------------------------------------------------------------------
@@ -1956,9 +1942,9 @@ ClockParseformatargsObjCmd(
int
ClockSecondsObjCmd(
ClientData clientData, /* Client data is unused */
- Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
- Tcl_Obj* const* objv) /* Parameter values */
+ Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
@@ -1991,9 +1977,9 @@ ClockSecondsObjCmd(
static void
TzsetIfNecessary(void)
{
- static char* tzWas = NULL; /* Previous value of TZ, protected by
+ static char *tzWas = NULL; /* Previous value of TZ, protected by
* clockMutex. */
- const char* tzIsNow; /* Current value of TZ */
+ const char *tzIsNow; /* Current value of TZ */
Tcl_MutexLock(&clockMutex);
tzIsNow = getenv("TZ");
@@ -2030,16 +2016,16 @@ static void
ClockDeleteCmdProc(
ClientData clientData) /* Opaque pointer to the client data */
{
- ClockClientData *data = (ClockClientData*) clientData;
+ ClockClientData *data = clientData;
int i;
- --(data->refCount);
+ data->refCount--;
if (data->refCount == 0) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
- ckfree((char*) (data->literals));
- ckfree((char*) data);
+ ckfree(data->literals);
+ ckfree(data);
}
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index d8db34e..765c9dc 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -15,6 +15,26 @@
#include <locale.h>
/*
+ * The state structure used by [foreach]. Note that the actual structure has
+ * all its working arrays appended afterwards so they can be allocated and
+ * freed in a single step.
+ */
+
+struct ForeachState {
+ Tcl_Obj *bodyPtr; /* The script body of the command. */
+ int bodyIdx; /* The argument index of the body. */
+ int j, maxj; /* Number of loop iterations. */
+ int numLists; /* Count of value lists. */
+ int *index; /* Array of value list indices. */
+ int *varcList; /* # loop variables per list. */
+ Tcl_Obj ***varvList; /* Array of var name lists. */
+ Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
+ int *argcList; /* Array of value list sizes. */
+ Tcl_Obj ***argvList; /* Array of value lists. */
+ Tcl_Obj **aCopyList; /* Copies of value list arguments. */
+};
+
+/*
* Prototypes for local procedures defined in this file:
*/
@@ -22,12 +42,50 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
static int EncodingDirsObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
+static inline int ForeachAssignments(Tcl_Interp *interp,
+ struct ForeachState *statePtr);
+static inline void ForeachCleanup(Tcl_Interp *interp,
+ struct ForeachState *statePtr);
static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
-static char * GetTypeFromMode(int mode);
+static const char * GetTypeFromMode(int mode);
static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
+static Tcl_NRPostProc CatchObjCmdCallback;
+static Tcl_NRPostProc ExprCallback;
+static Tcl_NRPostProc ForSetupCallback;
+static Tcl_NRPostProc ForCondCallback;
+static Tcl_NRPostProc ForNextCallback;
+static Tcl_NRPostProc ForPostNextCallback;
+static Tcl_NRPostProc ForeachLoopStep;
+static Tcl_NRPostProc EvalCmdErrMsg;
+
+static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
+static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
+static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
+static Tcl_ObjCmdProc FileAttrIsExistingCmd;
+static Tcl_ObjCmdProc FileAttrIsFileCmd;
+static Tcl_ObjCmdProc FileAttrIsOwnedCmd;
+static Tcl_ObjCmdProc FileAttrIsReadableCmd;
+static Tcl_ObjCmdProc FileAttrIsWritableCmd;
+static Tcl_ObjCmdProc FileAttrLinkStatCmd;
+static Tcl_ObjCmdProc FileAttrModifyTimeCmd;
+static Tcl_ObjCmdProc FileAttrSizeCmd;
+static Tcl_ObjCmdProc FileAttrStatCmd;
+static Tcl_ObjCmdProc FileAttrTypeCmd;
+static Tcl_ObjCmdProc FilesystemSeparatorCmd;
+static Tcl_ObjCmdProc FilesystemVolumesCmd;
+static Tcl_ObjCmdProc PathDirNameCmd;
+static Tcl_ObjCmdProc PathExtensionCmd;
+static Tcl_ObjCmdProc PathFilesystemCmd;
+static Tcl_ObjCmdProc PathJoinCmd;
+static Tcl_ObjCmdProc PathNativeNameCmd;
+static Tcl_ObjCmdProc PathNormalizeCmd;
+static Tcl_ObjCmdProc PathRootNameCmd;
+static Tcl_ObjCmdProc PathSplitCmd;
+static Tcl_ObjCmdProc PathTailCmd;
+static Tcl_ObjCmdProc PathTypeCmd;
/*
*----------------------------------------------------------------------
@@ -56,7 +114,7 @@ Tcl_BreakObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -89,17 +147,17 @@ Tcl_CaseObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register int i;
int body, result, caseObjc;
- char *stringPtr, *arg;
- Tcl_Obj *CONST *caseObjv;
+ const char *stringPtr, *arg;
+ Tcl_Obj *const *caseObjv;
Tcl_Obj *armPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
- "string ?in? patList body ... ?default body?");
+ "string ?in? ?pattern body ...? ?default body?");
return TCL_ERROR;
}
@@ -129,11 +187,11 @@ Tcl_CaseObjCmd(
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
- CONST char **patObjv;
- char *pat;
+ const char **patObjv;
+ const char *pat;
unsigned char *p;
- if (i == (caseObjc - 1)) {
+ if (i == caseObjc-1) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
return TCL_ERROR;
@@ -176,7 +234,7 @@ Tcl_CaseObjCmd(
break;
}
}
- ckfree((char *) patObjv);
+ ckfree(patObjv);
if (j < patObjc) {
break;
}
@@ -189,7 +247,7 @@ Tcl_CaseObjCmd(
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.50s\" arm line %d)",
- TclGetString(armPtr), interp->errorLine));
+ TclGetString(armPtr), Tcl_GetErrorLine(interp)));
}
return result;
}
@@ -224,11 +282,20 @@ Tcl_CatchObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRCatchObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
- int result;
Interp *iPtr = (Interp *) interp;
if ((objc < 2) || (objc > 4)) {
@@ -244,39 +311,50 @@ Tcl_CatchObjCmd(
optionVarNamePtr = objv[3];
}
+ TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
+ varNamePtr, optionVarNamePtr, NULL);
+
/*
* TIP #280. Make invoking context available to caught script.
*/
- result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+ return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+}
+
+static int
+CatchObjCmdCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj *varNamePtr = data[1];
+ Tcl_Obj *optionVarNamePtr = data[2];
+ int rewind = iPtr->execEnvPtr->rewind;
/*
* We disable catch in interpreters where the limit has been exceeded.
*/
- if (Tcl_LimitExceeded(interp)) {
+ if (rewind || Tcl_LimitExceeded(interp)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"catch\" body line %d)", interp->errorLine));
+ "\n (\"catch\" body line %d)", Tcl_GetErrorLine(interp)));
return TCL_ERROR;
}
if (objc >= 3) {
if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
- Tcl_GetObjResult(interp), 0)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "couldn't save command result in variable", NULL);
+ Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
}
if (objc == 4) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
+
if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
- options, 0)) {
+ options, TCL_LEAVE_ERR_MSG)) {
Tcl_DecrRefCount(options);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "couldn't save return options in variable", NULL);
return TCL_ERROR;
}
}
@@ -309,7 +387,7 @@ Tcl_CdObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dir;
int result;
@@ -364,7 +442,7 @@ Tcl_ConcatObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc >= 2) {
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
@@ -399,7 +477,7 @@ Tcl_ContinueObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -429,11 +507,11 @@ Tcl_EncodingObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int index;
- static CONST char *optionStrings[] = {
+ static const char *const optionStrings[] = {
"convertfrom", "convertto", "dirs", "names", "system",
NULL
};
@@ -457,7 +535,7 @@ Tcl_EncodingObjCmd(
Tcl_DString ds;
Tcl_Encoding encoding;
int length;
- char *stringPtr;
+ const char *stringPtr;
if (objc == 3) {
encoding = Tcl_GetEncoding(interp, NULL);
@@ -550,7 +628,7 @@ EncodingDirsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
@@ -563,6 +641,8 @@ EncodingDirsObjCmd(
if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) {
Tcl_AppendResult(interp, "expected directory list but got \"",
TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
+ NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
@@ -592,7 +672,7 @@ Tcl_ErrorObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options, *optName;
@@ -637,16 +717,30 @@ Tcl_ErrorObjCmd(
*/
/* ARGSUSED */
+static int
+EvalCmdErrMsg(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)));
+ }
+ return result;
+}
+
int
Tcl_EvalObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- int result;
register Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
+ CmdFrame *invoker = NULL;
+ int word = 0;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
@@ -658,32 +752,24 @@ Tcl_EvalObjCmd(
* TIP #280. Make argument location available to eval'd script.
*/
- CmdFrame* invoker = iPtr->cmdFramePtr;
- int word = 1;
- TclArgumentGet (interp, objv[1], &invoker, &word);
-
- result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
- invoker, word);
+ invoker = iPtr->cmdFramePtr;
+ word = 1;
+ objPtr = objv[1];
+ TclArgumentGet(interp, objPtr, &invoker, &word);
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete the
* object when it decrements its refcount after eval'ing it.
+ *
+ * TIP #280. Make invoking context available to eval'd script, done
+ * with the default values.
*/
objPtr = Tcl_ConcatObj(objc-1, objv+1);
-
- /*
- * TIP #280. Make invoking context available to eval'd script.
- */
-
- result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
}
- if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"eval\" body line %d)", interp->errorLine));
- }
- return result;
+ TclNRAddCallback(interp, EvalCmdErrMsg, NULL, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
/*
@@ -709,7 +795,7 @@ Tcl_ExitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int value;
@@ -758,43 +844,69 @@ Tcl_ExprObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Obj *resultPtr;
- int result;
+ return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRExprObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *resultPtr, *objPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
+ TclNewObj(resultPtr);
+ Tcl_IncrRefCount(resultPtr);
if (objc == 2) {
- result = Tcl_ExprObj(interp, objv[1], &resultPtr);
+ objPtr = objv[1];
+ TclNRAddCallback(interp, ExprCallback, resultPtr, NULL, NULL, NULL);
} else {
- Tcl_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1);
- Tcl_IncrRefCount(objPtr);
- result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ objPtr = Tcl_ConcatObj(objc-1, objv+1);
+ TclNRAddCallback(interp, ExprCallback, resultPtr, objPtr, NULL, NULL);
+ }
+
+ return Tcl_NRExprObj(interp, objPtr, resultPtr);
+}
+
+static int
+ExprCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultPtr = data[0];
+ Tcl_Obj *objPtr = data[1];
+
+ if (objPtr != NULL) {
Tcl_DecrRefCount(objPtr);
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
- Tcl_DecrRefCount(resultPtr); /* Done with the result object */
}
-
+ Tcl_DecrRefCount(resultPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FileObjCmd --
+ * TclInitFileCmd --
+ *
+ * This function builds the "file" Tcl command ensemble. See the user
+ * documentation for details on what that ensemble does.
*
- * This procedure is invoked to process the "file" Tcl command. See the
- * user documentation for details on what it does. PLEASE NOTE THAT THIS
- * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the
- * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any
- * case this assertion should be tested.
+ * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH EMBEDDED
+ * NULLS. With the object-based Tcl_FS APIs, the above NOTE may no longer
+ * be true. In any case this assertion should be tested.
*
* Results:
* A standard Tcl result.
@@ -805,573 +917,1166 @@ Tcl_ExprObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-int
-Tcl_FileObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+Tcl_Command
+TclInitFileCmd(
+ Tcl_Interp *interp)
{
- int index, value;
- Tcl_StatBuf buf;
- struct utimbuf tval;
-
/*
- * This list of constants should match the fileOption string array below.
+ * Note that most subcommands are unsafe because either they manipulate
+ * the native filesystem or because they reveal information about the
+ * native filesystem.
*/
- static CONST char *fileOptions[] = {
- "atime", "attributes", "channels", "copy",
- "delete",
- "dirname", "executable", "exists", "extension",
- "isdirectory", "isfile", "join", "link",
- "lstat", "mtime", "mkdir", "nativename",
- "normalize", "owned",
- "pathtype", "readable", "readlink", "rename",
- "rootname", "separator", "size", "split",
- "stat", "system",
- "tail", "type", "volumes", "writable",
- NULL
+ 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},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
- enum options {
- FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
- FCMD_DELETE,
- FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
- FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
- FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
- FCMD_NORMALIZE, FCMD_OWNED,
- FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
- FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
- FCMD_STAT, FCMD_SYSTEM,
- FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
+ return TclMakeEnsemble(interp, "file", initMap);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMakeFileCommandSafe --
+ *
+ * This function hides the unsafe subcommands of the "file" Tcl command
+ * ensemble. It must only be called from TclHideUnsafeCommands.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Adds commands to the table of hidden commands.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclMakeFileCommandSafe(
+ Tcl_Interp *interp)
+{
+ static const struct {
+ const char *cmdName;
+ int unsafe;
+ } unsafeInfo[] = {
+ {"atime", 1},
+ {"attributes", 1},
+ {"channels", 0},
+ {"copy", 1},
+ {"delete", 1},
+ {"dirname", 1},
+ {"executable", 1},
+ {"exists", 1},
+ {"extension", 1},
+ {"isdirectory", 1},
+ {"isfile", 1},
+ {"join", 0},
+ {"link", 1},
+ {"lstat", 1},
+ {"mtime", 1},
+ {"mkdir", 1},
+ {"nativename", 1},
+ {"normalize", 1},
+ {"owned", 1},
+ {"pathtype", 0},
+ {"readable", 1},
+ {"readlink", 1},
+ {"rename", 1},
+ {"rootname", 1},
+ {"separator", 0},
+ {"size", 1},
+ {"split", 0},
+ {"stat", 1},
+ {"system", 0},
+ {"tail", 1},
+ {"tempfile", 1},
+ {"type", 1},
+ {"volumes", 1},
+ {"writable", 1},
+ {NULL, 0}
};
+ int i;
+ Tcl_DString oldBuf, newBuf;
+
+ Tcl_DStringInit(&oldBuf);
+ Tcl_DStringAppend(&oldBuf, "::tcl::file::", -1);
+ Tcl_DStringInit(&newBuf);
+ Tcl_DStringAppend(&newBuf, "tcl:file:", -1);
+ for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
+ if (unsafeInfo[i].unsafe) {
+ const char *oldName, *newName;
+
+ Tcl_DStringSetLength(&oldBuf, 13);
+ oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
+ Tcl_DStringSetLength(&newBuf, 9);
+ newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
+ if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
+ Tcl_Panic("problem making 'file %s' safe: %s",
+ unsafeInfo[i].cmdName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ }
+ }
+ Tcl_DStringFree(&oldBuf);
+ Tcl_DStringFree(&newBuf);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrAccessTimeCmd --
+ *
+ * This function is invoked to process the "file atime" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May update the access time on the file, if requested by the user.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+static int
+FileAttrAccessTimeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ struct utimbuf tval;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?time?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
- &index) != TCL_OK) {
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
+ if (objc == 3) {
+ /*
+ * Need separate variable for reading longs from an object on 64-bit
+ * platforms. [Bug 698146]
+ */
- switch ((enum options) index) {
+ long newTime;
- case FCMD_ATIME:
- case FCMD_MTIME:
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+
+ tval.actime = newTime;
+ tval.modtime = buf.st_mtime;
+
+ if (Tcl_FSUtime(objv[1], &tval) != 0) {
+ Tcl_AppendResult(interp, "could not set access time for file \"",
+ TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
+ NULL);
return TCL_ERROR;
}
- if (objc == 4) {
- /*
- * Need separate variable for reading longs from an object on
- * 64-bit platforms. [Bug #698146]
- */
- long newTime;
+ /*
+ * Do another stat to ensure that the we return the new recognized
+ * atime - hopefully the same as the one we sent in. However, fs's
+ * like FAT don't even know what atime is.
+ */
- if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
- if (index == FCMD_ATIME) {
- tval.actime = newTime;
- tval.modtime = buf.st_mtime;
- } else { /* index == FCMD_MTIME */
- tval.actime = buf.st_atime;
- tval.modtime = newTime;
- }
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrModifyTimeCmd --
+ *
+ * This function is invoked to process the "file mtime" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May update the modification time on the file, if requested by the
+ * user.
+ *
+ *----------------------------------------------------------------------
+ */
- if (Tcl_FSUtime(objv[2], &tval) != 0) {
- Tcl_AppendResult(interp, "could not set ",
- (index == FCMD_ATIME ? "access" : "modification"),
- " time for file \"", TclGetString(objv[2]), "\": ",
- Tcl_PosixError(interp), NULL);
- return TCL_ERROR;
- }
+static int
+FileAttrModifyTimeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ struct utimbuf tval;
- /*
- * Do another stat to ensure that the we return the new recognized
- * atime - hopefully the same as the one we sent in. However, fs's
- * like FAT don't even know what atime is.
- */
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?time?");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ /*
+ * Need separate variable for reading longs from an object on 64-bit
+ * platforms. [Bug 698146]
+ */
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- }
+ long newTime;
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long)
- (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime)));
- return TCL_OK;
- case FCMD_ATTRIBUTES:
- return TclFileAttrsCmd(interp, objc, objv);
- case FCMD_CHANNELS:
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
+ if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_GetChannelNamesEx(interp,
- ((objc == 2) ? NULL : TclGetString(objv[2])));
- case FCMD_COPY:
- return TclFileCopyCmd(interp, objc, objv);
- case FCMD_DELETE:
- return TclFileDeleteCmd(interp, objc, objv);
- case FCMD_DIRNAME: {
- Tcl_Obj *dirPtr;
-
- if (objc != 3) {
- goto only3Args;
- }
- dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
- if (dirPtr == NULL) {
+
+ tval.actime = buf.st_atime;
+ tval.modtime = newTime;
+
+ if (Tcl_FSUtime(objv[1], &tval) != 0) {
+ Tcl_AppendResult(interp, "could not set modification time for "
+ "file \"", TclGetString(objv[1]), "\": ",
+ Tcl_PosixError(interp), NULL);
return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, dirPtr);
- Tcl_DecrRefCount(dirPtr);
- return TCL_OK;
- }
- }
- case FCMD_EXECUTABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], X_OK);
- case FCMD_EXISTS:
- if (objc != 3) {
- goto only3Args;
}
- return CheckAccess(interp, objv[2], F_OK);
- case FCMD_EXTENSION: {
- Tcl_Obj *ext;
- if (objc != 3) {
- goto only3Args;
- }
- ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
- if (ext != NULL) {
- Tcl_SetObjResult(interp, ext);
- Tcl_DecrRefCount(ext);
- return TCL_OK;
- } else {
+ /*
+ * Do another stat to ensure that the we return the new recognized
+ * mtime - hopefully the same as the one we sent in.
+ */
+
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
- case FCMD_ISDIRECTORY:
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- value = S_ISDIR(buf.st_mode);
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
- return TCL_OK;
- case FCMD_ISFILE:
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- value = S_ISREG(buf.st_mode);
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
- return TCL_OK;
- case FCMD_OWNED:
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- /*
- * For Windows, there are no user ids associated with a file, so
- * we always return 1.
- */
-#if defined(__WIN32__)
- value = 1;
-#else
- value = (geteuid() == buf.st_uid);
-#endif
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
- return TCL_OK;
- case FCMD_JOIN: {
- Tcl_Obj *resObj;
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrLinkStatCmd --
+ *
+ * This function is invoked to process the "file lstat" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Writes to an array named by the user.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
- return TCL_ERROR;
- }
- resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
- Tcl_SetObjResult(interp, resObj);
- return TCL_OK;
+static int
+FileAttrLinkStatCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ return TCL_ERROR;
}
- case FCMD_LINK: {
- Tcl_Obj *contents;
- int index;
+ if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return StoreStatData(interp, objv[2], &buf);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrStatCmd --
+ *
+ * This function is invoked to process the "file stat" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Writes to an array named by the user.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc < 3 || objc > 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?");
- return TCL_ERROR;
- }
+static int
+FileAttrStatCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return StoreStatData(interp, objv[2], &buf);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrTypeCmd --
+ *
+ * This function is invoked to process the "file type" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrTypeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ GetTypeFromMode((unsigned short) buf.st_mode), -1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrSizeCmd --
+ *
+ * This function is invoked to process the "file size" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrSizeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsDirectoryCmd --
+ *
+ * This function is invoked to process the "file isdirectory" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrIsDirectoryCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ int value = 0;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
+ value = S_ISDIR(buf.st_mode);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsExecutableCmd --
+ *
+ * This function is invoked to process the "file executable" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrIsExecutableCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ return CheckAccess(interp, objv[1], X_OK);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsExistingCmd --
+ *
+ * This function is invoked to process the "file exists" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrIsExistingCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ return CheckAccess(interp, objv[1], F_OK);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsFileCmd --
+ *
+ * This function is invoked to process the "file isfile" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrIsFileCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ int value = 0;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
+ value = S_ISREG(buf.st_mode);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsOwnedCmd --
+ *
+ * This function is invoked to process the "file owned" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileAttrIsOwnedCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_StatBuf buf;
+ int value = 0;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
/*
- * Index of the 'source' argument.
+ * For Windows, there are no user ids associated with a file, so we
+ * always return 1.
+ *
+ * TODO: use GetSecurityInfo to get the real owner of the file and
+ * test for equivalence to the current user.
*/
- if (objc == 5) {
- index = 3;
- } else {
- index = 2;
- }
+#ifdef __WIN32__
+ value = 1;
+#else
+ value = (geteuid() == buf.st_uid);
+#endif
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsReadableCmd --
+ *
+ * This function is invoked to process the "file readable" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc > 3) {
- int linkAction;
- if (objc == 5) {
- /*
- * We have a '-linktype' argument.
- */
-
- static CONST char *linkTypes[] = {
- "-symbolic", "-hard", NULL
- };
- if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch",
- 0, &linkAction) != TCL_OK) {
- return TCL_ERROR;
- }
- if (linkAction == 0) {
- linkAction = TCL_CREATE_SYMBOLIC_LINK;
- } else {
- linkAction = TCL_CREATE_HARD_LINK;
- }
- } else {
- linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
- }
- if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
- return TCL_ERROR;
- }
+static int
+FileAttrIsReadableCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ return CheckAccess(interp, objv[1], R_OK);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrIsWritableCmd --
+ *
+ * This function is invoked to process the "file writable" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Create link from source to target.
- */
+static int
+FileAttrIsWritableCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ return CheckAccess(interp, objv[1], W_OK);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathDirNameCmd --
+ *
+ * This function is invoked to process the "file dirname" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
- if (contents == NULL) {
- /*
- * We handle three common error cases specially, and for all
- * other errors, we use the standard posix error message.
- */
-
- if (errno == EEXIST) {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]),
- "\": that path already exists", NULL);
- } else if (errno == ENOENT) {
- /*
- * There are two cases here: either the target doesn't
- * exist, or the directory of the src doesn't exist.
- */
-
- int access;
- Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
- TCL_PATH_DIRNAME);
-
- if (dirPtr == NULL) {
- return TCL_ERROR;
- }
- access = Tcl_FSAccess(dirPtr, F_OK);
- Tcl_DecrRefCount(dirPtr);
- if (access != 0) {
- Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]),
- "\": no such file or directory", NULL);
- } else {
- Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]), "\": target \"",
- TclGetString(objv[index+1]),
- "\" doesn't exist", NULL);
- }
- } else {
- Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]), "\" pointing to \"",
- TclGetString(objv[index+1]), "\": ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
- }
- } else {
- if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
- return TCL_ERROR;
- }
+static int
+PathDirNameCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *dirPtr;
- /*
- * Read link
- */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ dirPtr = TclPathPart(interp, objv[1], TCL_PATH_DIRNAME);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathExtensionCmd --
+ *
+ * This function is invoked to process the "file extension" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- contents = Tcl_FSLink(objv[index], NULL, 0);
- if (contents == NULL) {
- Tcl_AppendResult(interp, "could not read link \"",
- TclGetString(objv[index]), "\": ",
- Tcl_PosixError(interp), NULL);
- return TCL_ERROR;
- }
- }
- Tcl_SetObjResult(interp, contents);
- if (objc == 3) {
- /*
- * If we are reading a link, we need to free this result refCount.
- * If we are creating a link, this will just be objv[index+1], and
- * so we don't own it.
- */
+static int
+PathExtensionCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *dirPtr;
- Tcl_DecrRefCount(contents);
- }
- return TCL_OK;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
}
- case FCMD_LSTAT:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "name varName");
- return TCL_ERROR;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- return StoreStatData(interp, objv[3], &buf);
- case FCMD_STAT:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "name varName");
- return TCL_ERROR;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- return StoreStatData(interp, objv[3], &buf);
- case FCMD_SIZE:
- if (objc != 3) {
- goto only3Args;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
- return TCL_OK;
- case FCMD_TYPE:
- if (objc != 3) {
- goto only3Args;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- GetTypeFromMode((unsigned short) buf.st_mode), -1));
- return TCL_OK;
- case FCMD_MKDIR:
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
- return TCL_ERROR;
- }
- return TclFileMakeDirsCmd(interp, objc, objv);
- case FCMD_NATIVENAME: {
- CONST char *fileName;
- Tcl_DString ds;
-
- if (objc != 3) {
- goto only3Args;
- }
- fileName = TclGetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
- Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
- return TCL_OK;
+ dirPtr = TclPathPart(interp, objv[1], TCL_PATH_EXTENSION);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
}
- case FCMD_NORMALIZE: {
- Tcl_Obj *fileName;
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathRootNameCmd --
+ *
+ * This function is invoked to process the "file root" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "filename");
- return TCL_ERROR;
- }
+static int
+PathRootNameCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *dirPtr;
- fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
- if (fileName == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, fileName);
- return TCL_OK;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
}
- case FCMD_PATHTYPE: {
- Tcl_Obj *typeName;
+ dirPtr = TclPathPart(interp, objv[1], TCL_PATH_ROOT);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathTailCmd --
+ *
+ * This function is invoked to process the "file tail" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- goto only3Args;
- }
+static int
+PathTailCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *dirPtr;
- switch (Tcl_FSGetPathType(objv[2])) {
- case TCL_PATH_ABSOLUTE:
- TclNewLiteralStringObj(typeName, "absolute");
- break;
- case TCL_PATH_RELATIVE:
- TclNewLiteralStringObj(typeName, "relative");
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- TclNewLiteralStringObj(typeName, "volumerelative");
- break;
- default:
- return TCL_OK;
- }
- Tcl_SetObjResult(interp, typeName);
- return TCL_OK;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
}
- case FCMD_READABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], R_OK);
- case FCMD_READLINK: {
- Tcl_Obj *contents;
+ dirPtr = TclPathPart(interp, objv[1], TCL_PATH_TAIL);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathFilesystemCmd --
+ *
+ * This function is invoked to process the "file system" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- goto only3Args;
- }
+static int
+PathFilesystemCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *fsInfo;
- if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ fsInfo = Tcl_FSFileSystemInfo(objv[1]);
+ if (fsInfo == NULL) {
+ Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
+ Tcl_GetString(objv[1]), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, fsInfo);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathJoinCmd --
+ *
+ * This function is invoked to process the "file join" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- contents = Tcl_FSLink(objv[2], NULL, 0);
+static int
+PathJoinCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_FSJoinToPath(NULL, objc - 1, objv + 1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathNativeNameCmd --
+ *
+ * This function is invoked to process the "file nativename" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (contents == NULL) {
- Tcl_AppendResult(interp, "could not readlink \"",
- TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
- NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, contents);
- Tcl_DecrRefCount(contents);
- return TCL_OK;
+static int
+PathNativeNameCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *fileName;
+ Tcl_DString ds;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds);
+ if (fileName == NULL) {
+ return TCL_ERROR;
}
- case FCMD_RENAME:
- return TclFileRenameCmd(interp, objc, objv);
- case FCMD_ROOTNAME: {
- Tcl_Obj *root;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
+ Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathNormalizeCmd --
+ *
+ * This function is invoked to process the "file normalize" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- goto only3Args;
- }
- root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
- if (root != NULL) {
- Tcl_SetObjResult(interp, root);
- Tcl_DecrRefCount(root);
- return TCL_OK;
- } else {
- return TCL_ERROR;
- }
+static int
+PathNormalizeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *fileName;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
}
- case FCMD_SEPARATOR:
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?name?");
- return TCL_ERROR;
- }
- if (objc == 2) {
- char *separator = NULL; /* lint */
+ fileName = Tcl_FSGetNormalizedPath(interp, objv[1]);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, fileName);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathSplitCmd --
+ *
+ * This function is invoked to process the "file split" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- separator = "/";
- break;
- case TCL_PLATFORM_WINDOWS:
- separator = "\\";
- break;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
- } else {
- Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
+static int
+PathSplitCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *res;
- if (separatorObj == NULL) {
- Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, separatorObj);
- }
- return TCL_OK;
- case FCMD_SPLIT: {
- Tcl_Obj *res;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ res = Tcl_FSSplitPath(objv[1], NULL);
+ if (res == NULL) {
+ Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]),
+ "\": no such file or directory", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, res);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PathTypeCmd --
+ *
+ * This function is invoked to process the "file pathtype" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- goto only3Args;
- }
- res = Tcl_FSSplitPath(objv[2], NULL);
- if (res == NULL) {
- /* How can the interp be NULL here?! DKF */
- if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(objv[2]),
- "\": no such file or directory", NULL);
- }
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, res);
+static int
+PathTypeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *typeName;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ switch (Tcl_FSGetPathType(objv[1])) {
+ case TCL_PATH_ABSOLUTE:
+ TclNewLiteralStringObj(typeName, "absolute");
+ break;
+ case TCL_PATH_RELATIVE:
+ TclNewLiteralStringObj(typeName, "relative");
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ TclNewLiteralStringObj(typeName, "volumerelative");
+ break;
+ default:
+ /* Should be unreachable */
return TCL_OK;
}
- case FCMD_SYSTEM: {
- Tcl_Obj *fsInfo;
+ Tcl_SetObjResult(interp, typeName);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FilesystemSeparatorCmd --
+ *
+ * This function is invoked to process the "file separator" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 3) {
- goto only3Args;
- }
- fsInfo = Tcl_FSFileSystemInfo(objv[2]);
- if (fsInfo == NULL) {
- Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, fsInfo);
- return TCL_OK;
+static int
+FilesystemSeparatorCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc < 1 || objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?name?");
+ return TCL_ERROR;
}
- case FCMD_TAIL: {
- Tcl_Obj *dirPtr;
+ if (objc == 1) {
+ const char *separator = NULL; /* lint */
- if (objc != 3) {
- goto only3Args;
- }
- dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
- if (dirPtr == NULL) {
- return TCL_ERROR;
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
}
- Tcl_SetObjResult(interp, dirPtr);
- Tcl_DecrRefCount(dirPtr);
- return TCL_OK;
- }
- case FCMD_VOLUMES:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
+ } else {
+ Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
+
+ if (separatorObj == NULL) {
+ Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
+ Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_FSListVolumes());
- return TCL_OK;
- case FCMD_WRITABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], W_OK);
+ Tcl_SetObjResult(interp, separatorObj);
}
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FilesystemVolumesCmd --
+ *
+ * This function is invoked to process the "file volumes" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- only3Args:
- Tcl_WrongNumArgs(interp, 2, objv, "name");
- return TCL_ERROR;
+static int
+FilesystemVolumesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_FSListVolumes());
+ return TCL_OK;
}
/*
@@ -1447,7 +2152,7 @@ GetStatBuf(
return TCL_ERROR;
}
- status = (*statProc)(pathPtr, statPtr);
+ status = statProc(pathPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
@@ -1510,7 +2215,7 @@ StoreStatData(
/*
* Watch out porters; the inode is meant to be an *unsigned* value, so the
- * cast might fail when there isn't a real arithmentic 'long long' type...
+ * cast might fail when there isn't a real arithmetic 'long long' type...
*/
STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
@@ -1552,7 +2257,7 @@ StoreStatData(
*----------------------------------------------------------------------
*/
-static char *
+static const char *
GetTypeFromMode(
int mode)
{
@@ -1597,6 +2302,25 @@ GetTypeFromMode(
* Side effects:
* See the user documentation.
*
+ * Notes:
+ * This command is split into a lot of pieces so that it can avoid doing
+ * reentrant TEBC calls. This makes things rather hard to follow, but
+ * here's the plan:
+ *
+ * NR: ---------------_\
+ * Direct: Tcl_ForObjCmd -> TclNRForObjCmd
+ * |
+ * ForSetupCallback
+ * |
+ * [while] ------------> TclNRForIterCallback <---------.
+ * | |
+ * ForCondCallback |
+ * | |
+ * ForNextCallback ------------|
+ * | |
+ * ForPostNextCallback |
+ * |____________________|
+ *
*----------------------------------------------------------------------
*/
@@ -1606,83 +2330,182 @@ Tcl_ForObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRForObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- int result, value;
Interp *iPtr = (Interp *) interp;
+ ForIterData *iterPtr;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
return TCL_ERROR;
}
+ TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr);
+ iterPtr->cond = objv[2];
+ iterPtr->body = objv[4];
+ iterPtr->next = objv[3];
+ iterPtr->msg = "\n (\"for\" body line %d)";
+ iterPtr->word = 4;
+
+ TclNRAddCallback(interp, ForSetupCallback, iterPtr, NULL, NULL, NULL);
+
/*
* TIP #280. Make invoking context available to initial script.
*/
- result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+ return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+}
+
+static int
+ForSetupCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ForIterData *iterPtr = data[0];
+
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
+ TclSmallFreeEx(interp, iterPtr);
return result;
}
- while (1) {
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
+ return TCL_OK;
+}
+
+int
+TclNRForIterCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ForIterData *iterPtr = data[0];
+ Tcl_Obj *boolObj;
+
+ switch (result) {
+ case TCL_OK:
+ case TCL_CONTINUE:
/*
- * We need to reset the result before passing it off to
- * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
- * to the result of the last evaluation.
+ * We need to reset the result before evaluating the expression.
+ * Otherwise, any error message will be appended to the result of the
+ * last evaluation.
*/
Tcl_ResetResult(interp);
- result = Tcl_ExprBooleanObj(interp, objv[2], &value);
- if (result != TCL_OK) {
- return result;
- }
- if (!value) {
- break;
- }
+ TclNewObj(boolObj);
+ TclNRAddCallback(interp, ForCondCallback, iterPtr, boolObj, NULL,
+ NULL);
+ return Tcl_NRExprObj(interp, iterPtr->cond, boolObj);
+ case TCL_BREAK:
+ result = TCL_OK;
+ Tcl_ResetResult(interp);
+ break;
+ case TCL_ERROR:
+ Tcl_AppendObjToErrorInfo(interp,
+ Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp)));
+ }
+ TclSmallFreeEx(interp, iterPtr);
+ return result;
+}
- /*
- * TIP #280. Make invoking context available to loop body.
- */
+static int
+ForCondCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ ForIterData *iterPtr = data[0];
+ Tcl_Obj *boolObj = data[1];
+ int value;
- result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4);
- if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
- if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"for\" body line %d)", interp->errorLine));
- }
- break;
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(boolObj);
+ TclSmallFreeEx(interp, iterPtr);
+ return result;
+ } else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
+ Tcl_DecrRefCount(boolObj);
+ TclSmallFreeEx(interp, iterPtr);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(boolObj);
+
+ if (value) {
+ /* TIP #280. */
+ if (iterPtr->next) {
+ TclNRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL,
+ NULL);
+ } else {
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
+ NULL, NULL);
}
+ return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr,
+ iterPtr->word);
+ }
+ TclSmallFreeEx(interp, iterPtr);
+ return result;
+}
+
+static int
+ForNextCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ ForIterData *iterPtr = data[0];
+ Tcl_Obj *next = iterPtr->next;
+
+ if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
+ TclNRAddCallback(interp, ForPostNextCallback, iterPtr, NULL, NULL,
+ NULL);
/*
* TIP #280. Make invoking context available to next script.
*/
- result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
- if (result == TCL_BREAK) {
- break;
- } else if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
- }
- return result;
- }
+ return TclNREvalObjEx(interp, next, 0, iPtr->cmdFramePtr, 3);
}
- if (result == TCL_BREAK) {
- result = TCL_OK;
- }
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
+
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
+ return result;
+}
+
+static int
+ForPostNextCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ForIterData *iterPtr = data[0];
+
+ if ((result != TCL_BREAK) && (result != TCL_OK)) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
+ TclSmallFreeEx(interp, iterPtr);
+ }
+ return result;
}
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ForeachObjCmd --
+ * Tcl_ForeachObjCmd, TclNRForeachCmd --
*
* This object-based procedure is invoked to process the "foreach" Tcl
* command. See the user documentation for details on what it does.
@@ -1702,23 +2525,21 @@ Tcl_ForeachObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- int result = TCL_OK;
- int i; /* i selects a value list */
- int j, maxj; /* Number of loop iterations */
- int v; /* v selects a loop variable */
- int numLists = (objc-2)/2; /* Count of value lists */
- Tcl_Obj *bodyPtr;
- Interp *iPtr = (Interp *) interp;
+ return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv);
+}
- int *index; /* Array of value list indices */
- int *varcList; /* # loop variables per list */
- Tcl_Obj ***varvList; /* Array of var name lists */
- Tcl_Obj **vCopyList; /* Copies of var name list arguments */
- int *argcList; /* Array of value list sizes */
- Tcl_Obj ***argvList; /* Array of value lists */
- Tcl_Obj **aCopyList; /* Copies of value list arguments */
+int
+TclNRForeachCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int numLists = (objc-2) / 2;
+ register struct ForeachState *statePtr;
+ int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1728,129 +2549,216 @@ Tcl_ForeachObjCmd(
/*
* Manage numList parallel value lists.
- * argvList[i] is a value list counted by argcList[i]l;
- * varvList[i] is the list of variables associated with the value list;
- * varcList[i] is the number of variables associated with the value list;
- * index[i] is the current pointer into the value list argvList[i].
+ * statePtr->argvList[i] is a value list counted by statePtr->argcList[i];
+ * statePtr->varvList[i] is the list of variables associated with the
+ * value list;
+ * statePtr->varcList[i] is the number of variables associated with the
+ * value list;
+ * statePtr->index[i] is the current pointer into the value list
+ * statePtr->argvList[i].
+ *
+ * The setting up of all of these pointers is moderately messy, but allows
+ * the rest of this code to be simple and for us to use a single memory
+ * allocation for better performance.
*/
- index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int));
- varcList = index + numLists;
- argcList = varcList + numLists;
- memset(index, 0, 3 * numLists * sizeof(int));
-
- varvList = (Tcl_Obj ***)
- TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **));
- argvList = varvList + numLists;
- memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **));
-
- vCopyList = (Tcl_Obj **)
- TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *));
- aCopyList = vCopyList + numLists;
- memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *));
+ statePtr = TclStackAlloc(interp,
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
+ memset(statePtr, 0,
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
+ statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
+ statePtr->argvList = statePtr->varvList + numLists;
+ statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists);
+ statePtr->aCopyList = statePtr->vCopyList + numLists;
+ statePtr->index = (int *) (statePtr->aCopyList + numLists);
+ statePtr->varcList = statePtr->index + numLists;
+ statePtr->argcList = statePtr->varcList + numLists;
+
+ statePtr->numLists = numLists;
+ statePtr->bodyPtr = objv[objc - 1];
+ statePtr->bodyIdx = objc - 1;
/*
* Break up the value lists and variable lists into elements.
*/
- maxj = 0;
for (i=0 ; i<numLists ; i++) {
-
- vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
- if (vCopyList[i] == NULL) {
+ statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
+ if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]);
- if (varcList[i] < 1) {
+ TclListObjGetElements(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i], &statePtr->varvList[i]);
+ if (statePtr->varcList[i] < 1) {
Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH",
+ "NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
- aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (aCopyList[i] == NULL) {
+ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]);
+ TclListObjGetElements(NULL, statePtr->aCopyList[i],
+ &statePtr->argcList[i], &statePtr->argvList[i]);
- j = argcList[i] / varcList[i];
- if ((argcList[i] % varcList[i]) != 0) {
+ j = statePtr->argcList[i] / statePtr->varcList[i];
+ if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
}
- if (j > maxj) {
- maxj = j;
+ if (j > statePtr->maxj) {
+ statePtr->maxj = j;
}
}
/*
- * Iterate maxj times through the lists in parallel. If some value lists
- * run out of values, set loop vars to ""
+ * If there is any work to do, assign the variables and set things going
+ * non-recursively.
*/
- bodyPtr = objv[objc-1];
- for (j=0 ; j<maxj ; j++) {
- for (i=0 ; i<numLists ; i++) {
- for (v=0 ; v<varcList[i] ; v++) {
- int k = index[i]++;
- Tcl_Obj *valuePtr, *varValuePtr;
-
- if (k < argcList[i]) {
- valuePtr = argvList[i][k];
- } else {
- valuePtr = Tcl_NewObj(); /* Empty string */
- }
- varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
- valuePtr, TCL_LEAVE_ERR_MSG);
- if (varValuePtr == NULL) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (setting foreach loop variable \"%s\")",
- TclGetString(varvList[i][v])));
- result = TCL_ERROR;
- goto done;
- }
- }
+ if (statePtr->maxj > 0) {
+ result = ForeachAssignments(interp, statePtr);
+ if (result == TCL_ERROR) {
+ goto done;
}
- /*
- * TIP #280. Make invoking context available to loop body.
- */
+ TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, objv[objc-1], 0,
+ ((Interp *) interp)->cmdFramePtr, objc-1);
+ }
- result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1);
- if (result != TCL_OK) {
- if (result == TCL_CONTINUE) {
- result = TCL_OK;
- } else if (result == TCL_BREAK) {
- result = TCL_OK;
- break;
- } else if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"foreach\" body line %d)",
- interp->errorLine));
- break;
+ /*
+ * This cleanup stage is only used when an error occurs during setup or if
+ * there is no work to do.
+ */
+
+ result = TCL_OK;
+ done:
+ ForeachCleanup(interp, statePtr);
+ return result;
+}
+
+/*
+ * Post-body processing handler.
+ */
+
+static int
+ForeachLoopStep(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ register struct ForeachState *statePtr = data[0];
+
+ /*
+ * Process the result code from this run of the [foreach] body. Note that
+ * this switch uses fallthroughs in several places. Maintainer aware!
+ */
+
+ switch (result) {
+ case TCL_CONTINUE:
+ result = TCL_OK;
+ case TCL_OK:
+ break;
+ case TCL_BREAK:
+ result = TCL_OK;
+ goto done;
+ case TCL_ERROR:
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp)));
+ default:
+ goto done;
+ }
+
+ /*
+ * Test if there is work still to be done. If so, do the next round of
+ * variable assignments, reschedule ourselves and run the body again.
+ */
+
+ if (statePtr->maxj > ++statePtr->j) {
+ result = ForeachAssignments(interp, statePtr);
+ if (result == TCL_ERROR) {
+ goto done;
+ }
+
+ TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, statePtr->bodyPtr, 0,
+ ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
+ }
+
+ /*
+ * We're done. Tidy up our work space and finish off.
+ */
+
+ Tcl_ResetResult(interp);
+ done:
+ ForeachCleanup(interp, statePtr);
+ return result;
+}
+
+/*
+ * Factored out code to do the assignments in [foreach].
+ */
+
+static inline int
+ForeachAssignments(
+ Tcl_Interp *interp,
+ struct ForeachState *statePtr)
+{
+ int i, v, k;
+ Tcl_Obj *valuePtr, *varValuePtr;
+
+ for (i=0 ; i<statePtr->numLists ; i++) {
+ for (v=0 ; v<statePtr->varcList[i] ; v++) {
+ k = statePtr->index[i]++;
+
+ if (k < statePtr->argcList[i]) {
+ valuePtr = statePtr->argvList[i][k];
} else {
- break;
+ TclNewObj(valuePtr); /* Empty string */
+ }
+
+ varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+
+ if (varValuePtr == NULL) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (setting foreach loop variable \"%s\")",
+ TclGetString(statePtr->varvList[i][v])));
+ return TCL_ERROR;
}
}
}
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- }
- done:
- for (i=0 ; i<numLists ; i++) {
- if (vCopyList[i]) {
- Tcl_DecrRefCount(vCopyList[i]);
+ return TCL_OK;
+}
+
+/*
+ * Factored out code for cleaning up the state of the foreach.
+ */
+
+static inline void
+ForeachCleanup(
+ Tcl_Interp *interp,
+ struct ForeachState *statePtr)
+{
+ int i;
+
+ for (i=0 ; i<statePtr->numLists ; i++) {
+ if (statePtr->vCopyList[i]) {
+ TclDecrRefCount(statePtr->vCopyList[i]);
}
- if (aCopyList[i]) {
- Tcl_DecrRefCount(aCopyList[i]);
+ if (statePtr->aCopyList[i]) {
+ TclDecrRefCount(statePtr->aCopyList[i]);
}
}
- TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */
- TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */
- TclStackFree(interp, index); /* int arrays */
- return result;
+ TclStackFree(interp, statePtr);
}
/*
@@ -1876,12 +2784,12 @@ Tcl_FormatObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr; /* Where result is stored finally. */
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?");
return TCL_ERROR;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 13db6d5..64348ad 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -3,7 +3,7 @@
*
* This file contains the top-level command routines for most of the Tcl
* built-in commands whose names begin with the letters I through L. It
- * contains only commands in the generic core (i.e. those that don't
+ * contains only commands in the generic core (i.e., those that don't
* depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
@@ -27,13 +27,16 @@
*/
typedef struct SortElement {
- union {
- char *strValuePtr;
- long intValue;
+ union { /* The value that we sorting by. */
+ const char *strValuePtr;
+ long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
- } index;
- Tcl_Obj *objPtr; /* Object being sorted, or its index. */
+ } collationKey;
+ union { /* Object being sorted, or its index. */
+ Tcl_Obj *objPtr;
+ int index;
+ } payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
} SortElement;
@@ -101,46 +104,51 @@ typedef struct SortInfo {
* Forward declarations for procedures defined in this file:
*/
-static int DictionaryCompare(char *left, char *right);
+static int DictionaryCompare(const char *left, const char *right);
+static int IfConditionCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
+/* TIP #348 - New 'info' subcommand 'errorstack' */
+static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
/* TIP #280 - New 'info' subcommand 'frame' */
static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoNameOfExecutableCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
-static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
+ int objc, Tcl_Obj *const objv[]);
+static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
SortInfo *infoPtr);
@@ -153,29 +161,31 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
*/
static const EnsembleImplMap defaultInfoMap[] = {
- {"args", InfoArgsCmd, NULL},
- {"body", InfoBodyCmd, NULL},
- {"cmdcount", InfoCmdCountCmd, NULL},
- {"commands", InfoCommandsCmd, NULL},
- {"complete", InfoCompleteCmd, NULL},
- {"default", InfoDefaultCmd, NULL},
- {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd},
- {"frame", InfoFrameCmd, NULL},
- {"functions", InfoFunctionsCmd, NULL},
- {"globals", TclInfoGlobalsCmd, NULL},
- {"hostname", InfoHostnameCmd, NULL},
- {"level", InfoLevelCmd, NULL},
- {"library", InfoLibraryCmd, NULL},
- {"loaded", InfoLoadedCmd, NULL},
- {"locals", TclInfoLocalsCmd, NULL},
- {"nameofexecutable", InfoNameOfExecutableCmd, NULL},
- {"patchlevel", InfoPatchLevelCmd, NULL},
- {"procs", InfoProcsCmd, NULL},
- {"script", InfoScriptCmd, NULL},
- {"sharedlibextension", InfoSharedlibCmd, NULL},
- {"tclversion", InfoTclVersionCmd, NULL},
- {"vars", TclInfoVarsCmd, NULL},
- {NULL, NULL, NULL}
+ {"args", InfoArgsCmd, NULL, NULL, NULL, 0},
+ {"body", InfoBodyCmd, NULL, NULL, NULL, 0},
+ {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0},
+ {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0},
+ {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0},
+ {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0},
+ {"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
+ {"errorstack", InfoErrorStackCmd, NULL, 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},
+ {"level", InfoLevelCmd, NULL, 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},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -204,42 +214,67 @@ Tcl_IfObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRIfObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *boolObj;
+
+ if (objc <= 1) {
+ Tcl_AppendResult(interp, "wrong # args: no expression after \"",
+ TclGetString(objv[0]), "\" argument", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * At this point, objv[1] refers to the main expression to test. The
+ * arguments after the expression must be "then" (optional) and a script
+ * to execute if the expression is true.
+ */
+
+ TclNewObj(boolObj);
+ Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
+ (ClientData) objv, INT2PTR(1), boolObj);
+ return Tcl_NRExprObj(interp, objv[1], boolObj);
+}
+
+static int
+IfConditionCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
{
- int thenScriptIndex = 0; /* "then" script to be evaled after syntax
- * check. */
Interp *iPtr = (Interp *) interp;
- int i, result, value;
- char *clause;
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj *const *objv = data[1];
+ int i = PTR2INT(data[2]);
+ Tcl_Obj *boolObj = data[3];
+ int value, thenScriptIndex = 0;
+ const char *clause;
- i = 1;
- while (1) {
- /*
- * At this point in the loop, objv and objc refer to an expression to
- * test, either for the main expression or an expression following an
- * "elseif". The arguments after the expression must be "then"
- * (optional) and a script to execute if the expression is true.
- */
+ if (result != TCL_OK) {
+ TclDecrRefCount(boolObj);
+ return result;
+ }
+ if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
+ TclDecrRefCount(boolObj);
+ return TCL_ERROR;
+ }
+ TclDecrRefCount(boolObj);
- if (i >= objc) {
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: ",
- "no expression after \"", clause, "\" argument", NULL);
- return TCL_ERROR;
- }
- if (!thenScriptIndex) {
- result = Tcl_ExprBooleanObj(interp, objv[i], &value);
- if (result != TCL_OK) {
- return result;
- }
- }
+ while (1) {
i++;
if (i >= objc) {
- missingScript:
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: ",
- "no script following \"", clause, "\" argument", NULL);
- return TCL_ERROR;
+ goto missingScript;
}
clause = TclGetString(objv[i]);
if ((i < objc) && (strcmp(clause, "then") == 0)) {
@@ -265,17 +300,36 @@ Tcl_IfObjCmd(
* TIP #280. Make invoking context available to branch.
*/
- return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
return TCL_OK;
}
clause = TclGetString(objv[i]);
- if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
- i++;
- continue;
+ if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) {
+ break;
+ }
+ i++;
+
+ /*
+ * At this point in the loop, objv and objc refer to an expression to
+ * test, either for the main expression or an expression following an
+ * "elseif". The arguments after the expression must be "then"
+ * (optional) and a script to execute if the expression is true.
+ */
+
+ if (i >= objc) {
+ Tcl_AppendResult(interp, "wrong # args: ",
+ "no expression after \"", clause, "\" argument", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+ if (!thenScriptIndex) {
+ TclNewObj(boolObj);
+ Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1],
+ INT2PTR(i), boolObj);
+ return Tcl_NRExprObj(interp, objv[i], boolObj);
}
- break;
}
/*
@@ -287,14 +341,13 @@ Tcl_IfObjCmd(
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "no script following \"else\" argument", NULL);
- return TCL_ERROR;
+ goto missingScript;
}
}
if (i < objc - 1) {
Tcl_AppendResult(interp, "wrong # args: ",
"extra words after \"else\" clause in \"if\" command", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
@@ -302,10 +355,17 @@ Tcl_IfObjCmd(
* TIP #280. Make invoking context available to branch/else.
*/
- return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
- return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
+ return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
+
+ missingScript:
+ clause = TclGetString(objv[i-1]);
+ Tcl_AppendResult(interp, "wrong # args: no script following \"", clause,
+ "\" argument", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
}
/*
@@ -334,7 +394,7 @@ Tcl_IncrObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *newValuePtr, *incrPtr;
@@ -375,7 +435,7 @@ Tcl_IncrObjCmd(
* documentation for details on what it does.
*
* Results:
- * FIXME
+ * Handle for the info command, or NULL on failure.
*
* Side effects:
* none
@@ -415,10 +475,10 @@ InfoArgsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
@@ -432,6 +492,7 @@ InfoArgsCmd(
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -476,10 +537,10 @@ InfoBodyCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
Proc *procPtr;
Tcl_Obj *bodyPtr, *resultPtr;
@@ -492,6 +553,7 @@ InfoBodyCmd(
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -511,7 +573,7 @@ InfoBodyCmd(
* run before. [Bug #545644]
*/
- (void) TclGetString(bodyPtr);
+ TclGetString(bodyPtr);
}
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
@@ -545,7 +607,7 @@ InfoCmdCountCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
@@ -587,10 +649,10 @@ InfoCommandsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *cmdName, *pattern;
- CONST char *simplePattern;
+ const char *cmdName, *pattern;
+ const char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
@@ -622,8 +684,8 @@ InfoCommandsCmd(
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0,
- &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr,
+ &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -659,7 +721,7 @@ InfoCommandsCmd(
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
- cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ cmd = Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
@@ -710,7 +772,7 @@ InfoCommandsCmd(
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
- cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ cmd = Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
@@ -769,7 +831,7 @@ InfoCommandsCmd(
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
- (char *)elemObjPtr, &isNew);
+ elemObjPtr, &isNew);
}
entryPtr = Tcl_NextHashEntry(&search);
}
@@ -794,7 +856,7 @@ InfoCommandsCmd(
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
- (char *) elemObjPtr, &isNew);
+ elemObjPtr, &isNew);
if (isNew) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else {
@@ -864,7 +926,7 @@ InfoCompleteCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command");
@@ -901,10 +963,10 @@ InfoDefaultCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- char *procName, *argName, *varName;
+ const char *procName, *argName;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
@@ -920,6 +982,8 @@ InfoDefaultCmd(
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
+ NULL);
return TCL_ERROR;
}
@@ -929,17 +993,18 @@ InfoDefaultCmd(
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
- localPtr->defValuePtr, 0);
+ localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
- goto defStoreError;
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
+
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
- nullObjPtr, 0);
+ nullObjPtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
- goto defStoreError;
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
}
@@ -949,13 +1014,57 @@ InfoDefaultCmd(
Tcl_AppendResult(interp, "procedure \"", procName,
"\" doesn't have an argument \"", argName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoErrorStackCmd --
+ *
+ * Called to implement the "info errorstack" command that returns information
+ * about the last error's call stack. Handles the following syntax:
+ *
+ * info errorstack ?interp?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
- defStoreError:
- varName = TclGetString(objv[3]);
- Tcl_AppendResult(interp, "couldn't store default value in variable \"",
- varName, "\"", NULL);
- return TCL_ERROR;
+static int
+InfoErrorStackCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Interp *target;
+ Interp *iPtr;
+
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ return TCL_ERROR;
+ }
+
+ target = interp;
+ if (objc == 2) {
+ target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ iPtr = (Interp *) target;
+ Tcl_SetObjResult(interp, iPtr->errorStack);
+
+ return TCL_OK;
}
/*
@@ -983,9 +1092,9 @@ TclInfoExistsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *varName;
+ const char *varName;
Var *varPtr;
if (objc != 2) {
@@ -1028,21 +1137,43 @@ InfoFrameCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int level;
+ int level, topLevel;
CmdFrame *framePtr;
+ topLevel = ((iPtr->cmdFramePtr == NULL)
+ ? 0
+ : iPtr->cmdFramePtr->level);
+
+
+ if (iPtr->execEnvPtr->corPtr) {
+ /*
+ * A coroutine: must fix the level computations AND the cmdFrame chain,
+ * which is interrupted at the base.
+ */
+
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ CmdFrame *runPtr = iPtr->cmdFramePtr;
+ CmdFrame *lastPtr = NULL;
+
+ topLevel += corPtr->caller.cmdFramePtr->level;
+ while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) {
+ lastPtr = runPtr;
+ runPtr = runPtr->nextPtr;
+ }
+ if (lastPtr && !runPtr) {
+ lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
+ }
+ }
+
if (objc == 1) {
/*
* Just "info frame".
*/
- int levels =
- (iPtr->cmdFramePtr == NULL ? 0 : iPtr->cmdFramePtr->level);
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj (levels));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
return TCL_OK;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
@@ -1056,35 +1187,31 @@ InfoFrameCmd(
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
return TCL_ERROR;
}
- if (level <= 0) {
- /*
- * Negative levels are adressing relative to the current frame's
- * depth.
- */
- if (iPtr->cmdFramePtr == NULL) {
- levelError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"",
- TclGetString(objv[1]), "\"", NULL);
- return TCL_ERROR;
- }
+ if ((level > topLevel) || (level <= - topLevel)) {
+ levelError:
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
+ TclGetString(objv[1]), NULL);
+ return TCL_ERROR;
+ }
- /*
- * Convert to absolute.
- */
+ /*
+ * Let us convert to relative so that we know how many levels to go back
+ */
- level += iPtr->cmdFramePtr->level;
+ if (level > 0) {
+ level -= topLevel;
}
- for (framePtr = iPtr->cmdFramePtr; framePtr != NULL;
- framePtr = framePtr->nextPtr) {
- if (framePtr->level == level) {
- break;
+ framePtr = iPtr->cmdFramePtr;
+ while (++level <= 0) {
+ framePtr = framePtr->nextPtr;
+ if (!framePtr) {
+ goto levelError;
}
}
- if (framePtr == NULL) {
- goto levelError;
- }
Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
return TCL_OK;
@@ -1112,6 +1239,7 @@ TclInfoFrame(
CmdFrame *framePtr) /* Frame to get info for. */
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *tmpObj;
Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to
* the dict. */
int lc = 0;
@@ -1119,14 +1247,12 @@ TclInfoFrame(
* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
- static CONST char *typeString[TCL_LOCATION_LAST] = {
+ static const char *const typeString[TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
- Tcl_Obj *tmpObj;
- Proc *procPtr =
- framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
+ Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
- /*
+ /*
* Pull the information and construct the dictionary to return, as list.
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
*/
@@ -1181,9 +1307,8 @@ TclInfoFrame(
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
- CmdFrame *fPtr;
+ CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame));
- fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*fPtr = *framePtr;
/*
@@ -1252,19 +1377,16 @@ TclInfoFrame(
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
+ Tcl_Obj *procNameObj;
+
/*
* This is a regular command.
*/
- char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr);
- char *nsName = procPtr->cmdPtr->nsPtr->fullName;
-
- ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1));
-
- if (strcmp(nsName, "::") != 0) {
- Tcl_AppendToObj(lv[lc-1], "::", -1);
- }
- Tcl_AppendToObj(lv[lc-1], procName, -1);
+ TclNewObj(procNameObj);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
+ procNameObj);
+ ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
int i;
@@ -1336,9 +1458,9 @@ InfoFunctionsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *pattern;
+ const char *pattern;
if (objc == 1) {
pattern = NULL;
@@ -1378,9 +1500,9 @@ InfoHostnameCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- CONST char *name;
+ const char *name;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1393,6 +1515,7 @@ InfoHostnameCmd(
return TCL_OK;
}
Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -1421,7 +1544,7 @@ InfoLevelCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
@@ -1464,6 +1587,8 @@ InfoLevelCmd(
levelError:
Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
@@ -1493,9 +1618,9 @@ InfoLibraryCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- CONST char *libDirName;
+ const char *libDirName;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1508,6 +1633,7 @@ InfoLibraryCmd(
return TCL_OK;
}
Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
return TCL_ERROR;
}
@@ -1537,9 +1663,9 @@ InfoLoadedCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *interpName;
+ const char *interpName;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
@@ -1580,7 +1706,7 @@ InfoNameOfExecutableCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1616,9 +1742,9 @@ InfoPatchLevelCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- CONST char *patchlevel;
+ const char *patchlevel;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1663,10 +1789,10 @@ InfoProcsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *cmdName, *pattern;
- CONST char *simplePattern;
+ const char *cmdName, *pattern;
+ const char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
@@ -1699,9 +1825,8 @@ InfoProcsCmd(
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
- &simplePattern);
+ TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr,
+ &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -1727,7 +1852,7 @@ InfoProcsCmd(
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1755,7 +1880,7 @@ InfoProcsCmd(
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1802,7 +1927,7 @@ InfoProcsCmd(
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
@@ -1851,7 +1976,7 @@ InfoScriptCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if ((objc != 1) && (objc != 2)) {
@@ -1898,7 +2023,7 @@ InfoSharedlibCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1936,7 +2061,7 @@ InfoTclVersionCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *version;
@@ -1976,7 +2101,7 @@ Tcl_JoinObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* The argument objects. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
int listLen, i;
Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
@@ -2033,15 +2158,15 @@ Tcl_LassignObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listCopyPtr;
Tcl_Obj **listObjv; /* The contents of the list. */
int listObjc; /* The length of the list. */
int code = TCL_OK;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "list varName ?varName ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
@@ -2055,20 +2180,22 @@ Tcl_LassignObjCmd(
objc -= 2;
objv += 2;
while (code == TCL_OK && objc > 0 && listObjc > 0) {
- if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
- *listObjv++, TCL_LEAVE_ERR_MSG)) {
+ if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++,
+ TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
}
- objc--; listObjc--;
+ objc--;
+ listObjc--;
}
if (code == TCL_OK && objc > 0) {
Tcl_Obj *emptyObj;
+
TclNewObj(emptyObj);
Tcl_IncrRefCount(emptyObj);
while (code == TCL_OK && objc-- > 0) {
- if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
- emptyObj, TCL_LEAVE_ERR_MSG)) {
+ if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
}
}
@@ -2105,13 +2232,13 @@ Tcl_LindexObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
@@ -2134,11 +2261,11 @@ Tcl_LindexObjCmd(
if (elemPtr == NULL) {
return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, elemPtr);
- Tcl_DecrRefCount(elemPtr);
- return TCL_OK;
}
+
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount(elemPtr);
+ return TCL_OK;
}
/*
@@ -2164,13 +2291,13 @@ Tcl_LinsertObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
int index, len, result;
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
@@ -2243,7 +2370,7 @@ Tcl_ListObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
- register Tcl_Obj *CONST objv[])
+ register Tcl_Obj *const objv[])
/* The argument objects. */
{
/*
@@ -2252,7 +2379,7 @@ Tcl_ListObjCmd(
*/
if (objc > 1) {
- Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1])));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1]));
}
return TCL_OK;
}
@@ -2279,7 +2406,7 @@ Tcl_LlengthObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- register Tcl_Obj *CONST objv[])
+ register Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
@@ -2325,55 +2452,77 @@ Tcl_LrangeObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- register Tcl_Obj *CONST objv[])
+ register Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj *listPtr, **elemPtrs;
- int listLen, first, result;
+ Tcl_Obj **elemPtrs;
+ int listLen, first, last, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
- /*
- * Make sure the list argument is a list object and get its length and a
- * pointer to its array of element pointers.
- */
-
- listPtr = TclListObjCopy(interp, objv[1]);
- if (listPtr == NULL) {
- return TCL_ERROR;
+ result = TclListObjLength(interp, objv[1], &listLen);
+ if (result != TCL_OK) {
+ return result;
}
- TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
- if (result == TCL_OK) {
- int last;
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (first < 0) {
+ first = 0;
+ }
- if (first < 0) {
- first = 0;
- }
+ result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
+ &last);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (last >= listLen) {
+ last = listLen - 1;
+ }
- result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
- &last);
- if (result == TCL_OK) {
- if (last >= listLen) {
- last = (listLen - 1);
- }
+ if (first > last) {
+ /*
+ * Returning an empty list is easy.
+ */
- if (first <= last) {
- int numElems = (last - first + 1);
+ return TCL_OK;
+ }
- Tcl_SetObjResult(interp,
- Tcl_NewListObj(numElems, &(elemPtrs[first])));
- }
+ result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (Tcl_IsShared(objv[1]) ||
+ ((ListRepPtr(objv[1])->refCount > 1))) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
+ &elemPtrs[first]));
+ } else {
+ /*
+ * In-place is possible.
+ */
+
+ if (last < (listLen - 1)) {
+ Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
+ 0, NULL);
}
+
+ /*
+ * This one is not conditioned on (first > 0) in order to preserve the
+ * string-canonizing effect of [lrange 0 end].
+ */
+
+ Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
+ Tcl_SetObjResult(interp, objv[1]);
}
- Tcl_DecrRefCount(listPtr);
- return result;
+ return TCL_OK;
}
/*
@@ -2398,27 +2547,28 @@ Tcl_LrepeatObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
- register Tcl_Obj *CONST objv[])
+ register Tcl_Obj *const objv[])
/* The argument objects. */
{
int elementCount, i, totalElems;
- Tcl_Obj *listPtr, **dataArray;
- List *listRepPtr;
+ Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
- * lrepeat posInt value ?value ...?
+ * lrepeat count ?value ...?
*/
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
- if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) {
+ if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
- if (elementCount < 1) {
- Tcl_AppendResult(interp, "must have a count of at least 1", NULL);
+ if (elementCount < 0) {
+ Tcl_SetObjResult(interp, Tcl_Format(NULL,
+ "bad count \"%d\": must be integer >= 0", 1, objv+1));
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL);
return TCL_ERROR;
}
@@ -2431,9 +2581,10 @@ Tcl_LrepeatObjCmd(
/* Final sanity check. Do not exceed limits on max list length. */
- if (objc > LIST_MAX/elementCount) {
+ if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
@@ -2444,9 +2595,12 @@ Tcl_LrepeatObjCmd(
*/
listPtr = Tcl_NewListObj(totalElems, NULL);
- listRepPtr = ListRepPtr(listPtr);
- listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ if (totalElems) {
+ List *listRepPtr = ListRepPtr(listPtr);
+
+ listRepPtr->elemCount = elementCount*objc;
+ dataArray = &listRepPtr->elements;
+ }
/*
* Set the elements. Note that we handle the common degenerate case of a
@@ -2455,6 +2609,7 @@ Tcl_LrepeatObjCmd(
* number of times.
*/
+ CLANG_ASSERT(dataArray);
if (objc == 1) {
register Tcl_Obj *tmpPtr = objv[0];
@@ -2500,14 +2655,14 @@ Tcl_LreplaceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Tcl_Obj *listPtr;
int first, last, listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "list first last ?element element ...?");
+ "list first last ?element ...?");
return TCL_ERROR;
}
@@ -2533,7 +2688,7 @@ Tcl_LreplaceObjCmd(
}
if (first < 0) {
- first = 0;
+ first = 0;
}
/*
@@ -2546,13 +2701,14 @@ Tcl_LreplaceObjCmd(
if ((first >= listLen) && (listLen > 0)) {
Tcl_AppendResult(interp, "list doesn't contain element ",
TclGetString(objv[2]), NULL);
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL);
return TCL_ERROR;
}
if (last >= listLen) {
- last = (listLen - 1);
+ last = listLen - 1;
}
if (first <= last) {
- numToDelete = (last - first + 1);
+ numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
@@ -2575,7 +2731,7 @@ Tcl_LreplaceObjCmd(
* optimize this case away.
*/
- Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, &(objv[4]));
+ Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4);
/*
* Set the interpreter's object result.
@@ -2607,7 +2763,7 @@ Tcl_LreverseObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj **elemv;
int elemc, i, j;
@@ -2621,7 +2777,7 @@ Tcl_LreverseObjCmd(
}
/*
- * If the list is empty, just return it [Bug 1876793]
+ * If the list is empty, just return it. [Bug 1876793]
*/
if (!elemc) {
@@ -2686,10 +2842,10 @@ Tcl_LsearchObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
- char *bytes, *patternBytes;
- int i, match, mode, index, result, listc, length, elemLen;
+ const char *bytes, *patternBytes;
+ int i, match, index, result, listc, length, elemLen, bisect;
int dataType, isIncreasing, lower, upper, patInt, objInt, offset;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
@@ -2697,19 +2853,19 @@ Tcl_LsearchObjCmd(
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
SortStrCmpFn_t strCmpFn = strcmp;
Tcl_RegExp regexp = NULL;
- static CONST char *options[] = {
- "-all", "-ascii", "-decreasing", "-dictionary",
+ static const char *const options[] = {
+ "-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
"-real", "-regexp", "-sorted", "-start",
"-subindices", NULL
};
enum options {
- LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
- LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX,
- LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT,
- LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START,
- LSEARCH_SUBINDICES
+ LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING,
+ LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
+ LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
+ LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
+ LSEARCH_START, LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2717,6 +2873,7 @@ Tcl_LsearchObjCmd(
enum modes {
EXACT, GLOB, REGEXP, SORTED
};
+ enum modes mode;
mode = GLOB;
dataType = ASCII;
@@ -2725,6 +2882,7 @@ Tcl_LsearchObjCmd(
inlineReturn = 0;
returnSubindices = 0;
negatedMatch = 0;
+ bisect = 0;
listPtr = NULL;
startPtr = NULL;
offset = 0;
@@ -2738,7 +2896,7 @@ Tcl_LsearchObjCmd(
sortInfo.indexc = 0;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
return TCL_ERROR;
}
@@ -2748,10 +2906,8 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch ((enum options) index) {
case LSEARCH_ALL: /* -all */
@@ -2760,6 +2916,10 @@ Tcl_LsearchObjCmd(
case LSEARCH_ASCII: /* -ascii */
dataType = ASCII;
break;
+ case LSEARCH_BISECT: /* -bisect */
+ mode = SORTED;
+ bisect = 1;
+ break;
case LSEARCH_DECREASING: /* -decreasing */
isIncreasing = 0;
sortInfo.isIncreasing = 0;
@@ -2812,11 +2972,10 @@ Tcl_LsearchObjCmd(
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
Tcl_AppendResult(interp, "missing starting index", NULL);
- return TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ result = TCL_ERROR;
+ goto done;
}
i++;
if (objv[i] == objv[objc - 2]) {
@@ -2838,7 +2997,7 @@ Tcl_LsearchObjCmd(
int j;
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
if (i > objc-4) {
if (startPtr != NULL) {
@@ -2847,6 +3006,7 @@ Tcl_LsearchObjCmd(
Tcl_AppendResult(interp,
"\"-index\" option must be followed by list index",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
@@ -2872,8 +3032,8 @@ Tcl_LsearchObjCmd(
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
- sortInfo.indexv = (int *)
- ckalloc(sizeof(int) * sortInfo.indexc);
+ sortInfo.indexv =
+ TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
}
/*
@@ -2885,12 +3045,10 @@ Tcl_LsearchObjCmd(
for (j=0 ; j<sortInfo.indexc ; j++) {
if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
}
break;
@@ -2908,10 +3066,20 @@ Tcl_LsearchObjCmd(
}
Tcl_AppendResult(interp,
"-subindices cannot be used without -index option", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
- if ((enum modes) mode == REGEXP) {
+ if (bisect && (allMatches || negatedMatch)) {
+ Tcl_AppendResult(interp,
+ "-bisect is not compatible with -all or -not", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
+ return TCL_ERROR;
+ }
+
+ if (mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
@@ -2937,10 +3105,8 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
}
@@ -2954,10 +3120,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -2968,10 +3131,7 @@ Tcl_LsearchObjCmd(
result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (offset < 0) {
offset = 0;
@@ -2984,7 +3144,7 @@ Tcl_LsearchObjCmd(
if (offset > listc-1) {
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
@@ -2997,7 +3157,7 @@ Tcl_LsearchObjCmd(
patObj = objv[objc - 1];
patternBytes = NULL;
- if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) {
+ if (mode == EXACT || mode == SORTED) {
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
@@ -3006,10 +3166,7 @@ Tcl_LsearchObjCmd(
case INTEGER:
result = TclGetIntFromObj(interp, patObj, &patInt);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -3022,10 +3179,7 @@ Tcl_LsearchObjCmd(
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -3048,7 +3202,7 @@ Tcl_LsearchObjCmd(
index = -1;
match = 0;
- if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
+ if (mode == SORTED && !allMatches && !negatedMatch) {
/*
* If the data is sorted, we can do a more intelligent search. Note
* that there is no point in being smart when -all was specified; in
@@ -3063,10 +3217,8 @@ Tcl_LsearchObjCmd(
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return sortInfo.resultCode;
+ result = sortInfo.resultCode;
+ goto done;
}
} else {
itemPtr = listv[i];
@@ -3083,10 +3235,7 @@ Tcl_LsearchObjCmd(
case INTEGER:
result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (patInt == objInt) {
match = 0;
@@ -3099,10 +3248,7 @@ Tcl_LsearchObjCmd(
case REAL:
result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (patDouble == objDouble) {
match = 0;
@@ -3126,10 +3272,16 @@ Tcl_LsearchObjCmd(
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with an
* early comparison).
+ *
+ * In bisect mode though, we want the last of equals.
*/
index = i;
- upper = i;
+ if (bisect) {
+ lower = i;
+ } else {
+ upper = i;
+ }
} else if (match > 0) {
if (isIncreasing) {
lower = i;
@@ -3144,7 +3296,9 @@ Tcl_LsearchObjCmd(
}
}
}
-
+ if (bisect && index < 0) {
+ index = lower;
+ }
} else {
/*
* We need to do a linear search, because (at least one) of:
@@ -3158,22 +3312,20 @@ Tcl_LsearchObjCmd(
}
for (i = offset; i < listc; i++) {
match = 0;
- if (sortInfo.indexc != 0) {
+ if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return sortInfo.resultCode;
+ result = sortInfo.resultCode;
+ goto done;
}
} else {
itemPtr = listv[i];
}
-
- switch ((enum modes) mode) {
+
+ switch (mode) {
case SORTED:
case EXACT:
switch ((enum datatypes) dataType) {
@@ -3205,10 +3357,7 @@ Tcl_LsearchObjCmd(
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
match = (objInt == patInt);
break;
@@ -3219,10 +3368,7 @@ Tcl_LsearchObjCmd(
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
match = (objDouble == patDouble);
break;
@@ -3241,10 +3387,8 @@ Tcl_LsearchObjCmd(
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
break;
}
@@ -3317,15 +3461,17 @@ Tcl_LsearchObjCmd(
} else {
Tcl_SetObjResult(interp, listv[index]);
}
+ result = TCL_OK;
/*
* Cleanup the index list array.
*/
+ done:
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
- return TCL_OK;
+ return result;
}
/*
@@ -3350,7 +3496,7 @@ Tcl_LsetObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
@@ -3360,7 +3506,8 @@ Tcl_LsetObjCmd(
*/
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "listVar ?index? ?index...? value");
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar ?index? ?index ...? value");
return TCL_ERROR;
}
@@ -3368,8 +3515,7 @@ Tcl_LsetObjCmd(
* Look up the list variable's value.
*/
- listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- TCL_LEAVE_ERR_MSG);
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
@@ -3435,32 +3581,33 @@ Tcl_LsortObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
int i, j, index, indices, length, nocase = 0, sortMode, indexc;
+ int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
SortElement *elementArray, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
- static CONST char *switches[] = {
+# define NUM_LISTS 30
+ SortElement *subList[NUM_LISTS+1];
+ /* This array holds pointers to temporary
+ * lists built during the merge sort. Element
+ * i of the array holds a list of length
+ * 2**i. */
+ static const char *const switches[] = {
"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
- "-index", "-indices", "-integer", "-nocase", "-real", "-unique", NULL
+ "-index", "-indices", "-integer", "-nocase", "-real", "-stride",
+ "-unique", NULL
};
enum Lsort_Switches {
LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY,
LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER,
- LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE
+ LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE
};
- /*
- * The subList array below holds pointers to temporary lists built during
- * the merge sort. Element i of the array holds a list of length 2**i.
- */
-# define NUM_LISTS 30
- SortElement *subList[NUM_LISTS+1];
-
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list");
return TCL_ERROR;
}
@@ -3474,30 +3621,31 @@ Tcl_LsortObjCmd(
sortInfo.indexc = 0;
sortInfo.unique = 0;
sortInfo.interp = interp;
- sortInfo.resultCode = TCL_OK;
+ sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
indices = 0;
+ group = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ indexPtr = NULL;
for (i = 1; i < objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
&index) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
switch ((enum Lsort_Switches) index) {
case LSORT_ASCII:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
- if (i == (objc-2)) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
+ if (i == objc-2) {
Tcl_AppendResult(interp,
"\"-command\" option must be followed "
"by comparison command", NULL);
- return TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
@@ -3513,55 +3661,41 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- Tcl_Obj **indices;
+ int indexc, dummy;
+ Tcl_Obj **indexv;
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- if (i == (objc-2)) {
+ if (i == objc-2) {
Tcl_AppendResult(interp, "\"-index\" option must be "
"followed by list index", NULL);
- return TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
-
- /*
- * Take copy to prevent shimmering problems.
- */
-
- if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
- &indices) != TCL_OK) {
- return TCL_ERROR;
+ if (TclListObjGetElements(interp, objv[i+1], &indexc,
+ &indexv) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
- switch (sortInfo.indexc) {
- case 0:
- sortInfo.indexv = NULL;
- break;
- case 1:
- sortInfo.indexv = &sortInfo.singleIndex;
- break;
- default:
- sortInfo.indexv = (int *)
- ckalloc(sizeof(int) * sortInfo.indexc);
- }
-
- /*
- * Fill the array by parsing each index. We don't know whether
- * their scale is sensible yet, but we at least perform the
- * syntactic check here.
- */
- for (j=0 ; j<sortInfo.indexc ; j++) {
- if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
- &sortInfo.indexv[j]) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
+ /*
+ * Check each of the indices for syntactic correctness. Note that
+ * we do not store the converted values here because we do not
+ * know if this is the only -index option yet and so we can't
+ * allocate any space; that happens after the scan through all the
+ * options is done.
+ */
+
+ for (j=0 ; j<indexc ; j++) {
+ if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ &dummy) != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
}
- i++;
+ indexPtr = objv[i+1];
+ i++;
break;
}
case LSORT_INTEGER:
@@ -3579,12 +3713,64 @@ Tcl_LsortObjCmd(
case LSORT_INDICES:
indices = 1;
break;
+ case LSORT_STRIDE:
+ if (i == objc-2) {
+ Tcl_AppendResult(interp, "\"-stride\" option must be ",
+ "followed by stride length", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ if (groupSize < 2) {
+ Tcl_AppendResult(interp, "stride length must be at least 2",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ group = 1;
+ i++;
+ break;
}
}
if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) {
sortInfo.sortMode = SORTMODE_ASCII_NC;
}
+ /*
+ * Now extract the -index list for real, if present. No failures are
+ * expected here; the values are all of the right type or convertible to
+ * it.
+ */
+
+ if (indexPtr) {
+ Tcl_Obj **indexv;
+
+ TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
+ break;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
+ break;
+ default:
+ sortInfo.indexv =
+ TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
+ }
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ &sortInfo.indexv[j]);
+ }
+ }
+
listObj = objv[objc-1];
if (sortInfo.sortMode == SORTMODE_COMMAND) {
@@ -3599,10 +3785,8 @@ Tcl_LsortObjCmd(
listObj = TclListObjCopy(interp, listObj);
if (listObj == NULL) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
/*
@@ -3619,10 +3803,8 @@ Tcl_LsortObjCmd(
TclDecrRefCount(listObj);
Tcl_IncrRefCount(newObjPtr);
TclDecrRefCount(newObjPtr);
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
@@ -3633,8 +3815,62 @@ Tcl_LsortObjCmd(
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
+
+ /*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #326]
+ */
+
+ if (group) {
+ if (length % groupSize) {
+ Tcl_AppendResult(interp,
+ "list size must be a multiple of the stride length",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
+ NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done;
+ }
+ length = length / groupSize;
+ if (sortInfo.indexc > 0) {
+ /*
+ * Use the first value in the list supplied to -index as the
+ * offset of the element within each group by which to sort.
+ */
+
+ groupOffset = sortInfo.indexv[0];
+ if (groupOffset <= SORTIDX_END) {
+ groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
+ }
+ if (groupOffset < 0 || groupOffset >= groupSize) {
+ Tcl_AppendResult(interp, "when used with \"-stride\", the "
+ "leading \"-index\" value must be within the group",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADINDEX", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ /*
+ * Do not shrink the actual memory block used; that doesn't
+ * work with TclStackAlloc-allocated memory. [Bug 2918962]
+ */
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
sortInfo.numElements = length;
-
+
indexc = sortInfo.indexc;
sortMode = sortInfo.sortMode;
if ((sortMode == SORTMODE_ASCII_NC)
@@ -3642,7 +3878,7 @@ Tcl_LsortObjCmd(
/*
* For this function's purpose all string-based modes are equivalent
*/
-
+
sortMode = SORTMODE_ASCII;
}
@@ -3651,7 +3887,7 @@ Tcl_LsortObjCmd(
* contain a sorted sublist of length 2**i. Use one extra subList at the
* end, always at NULL, to indicate the end of the lists.
*/
-
+
for (j=0 ; j<=NUM_LISTS ; j++) {
subList[j] = NULL;
}
@@ -3661,57 +3897,65 @@ Tcl_LsortObjCmd(
* begins sorting it into the sublists as it appears.
*/
- elementArray = (SortElement *) ckalloc( length * sizeof(SortElement));
+ elementArray = TclStackAlloc(interp, length * sizeof(SortElement));
for (i=0; i < length; i++){
+ idx = groupSize * i + groupOffset;
if (indexc) {
/*
* If this is an indexed sort, retrieve the corresponding element
*/
- indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo);
+ indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
goto done1;
}
} else {
- indexPtr = listObjPtrs[i];
+ indexPtr = listObjPtrs[idx];
}
/*
* Determine the "value" of this object for sorting purposes
*/
-
+
if (sortMode == SORTMODE_ASCII) {
- elementArray[i].index.strValuePtr = TclGetString(indexPtr);
+ elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
} else if (sortMode == SORTMODE_INTEGER) {
long a;
+
if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done1;
}
- elementArray[i].index.intValue = a;
+ elementArray[i].collationKey.intValue = a;
} else if (sortInfo.sortMode == SORTMODE_REAL) {
double a;
- if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
+
+ if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
+ &a) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done1;
}
- elementArray[i].index.doubleValue = a;
+ elementArray[i].collationKey.doubleValue = a;
} else {
- elementArray[i].index.objValuePtr = indexPtr;
+ elementArray[i].collationKey.objValuePtr = indexPtr;
}
/*
* Determine the representation of this element in the result: either
* the objPtr itself, or its index in the original list.
*/
-
- elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]);
+
+ if (indices || group) {
+ elementArray[i].payload.index = idx;
+ } else {
+ elementArray[i].payload.objPtr = listObjPtrs[idx];
+ }
/*
* Merge this element in the pre-existing sublists (and merge together
* sublists when we have two of the same size).
*/
-
+
elementArray[i].nextPtr = NULL;
elementPtr = &elementArray[i];
for (j=0 ; subList[j] ; j++) {
@@ -3727,34 +3971,47 @@ Tcl_LsortObjCmd(
/*
* Merge all sublists
*/
-
+
elementPtr = subList[0];
for (j=1 ; j<NUM_LISTS ; j++) {
elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);
}
-
/*
* Now store the sorted elements in the result list.
*/
-
+
if (sortInfo.resultCode == TCL_OK) {
List *listRepPtr;
Tcl_Obj **newArray, *objPtr;
- int i;
-
- resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL);
+
+ resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
- if (indices) {
- for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
- objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr));
+ if (group) {
+ for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
+ idx = elementPtr->payload.index;
+ for (j = 0; j < groupSize; j++) {
+ if (indices) {
+ objPtr = Tcl_NewIntObj(idx + j - groupOffset);
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ } else {
+ objPtr = listObjPtrs[idx + j - groupOffset];
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ }
+ }
+ }
+ } else if (indices) {
+ for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
+ objPtr = Tcl_NewIntObj(elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
} else {
- for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
- objPtr = elementPtr->objPtr;
+ for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
+ objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -3764,7 +4021,7 @@ Tcl_LsortObjCmd(
}
done1:
- ckfree((char *)elementArray);
+ TclStackFree(interp, elementArray);
done:
if (sortInfo.sortMode == SORTMODE_COMMAND) {
@@ -3772,8 +4029,9 @@ Tcl_LsortObjCmd(
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ done2:
+ if (allocatedIndexVector) {
+ TclStackFree(interp, sortInfo.indexv);
}
return sortInfo.resultCode;
}
@@ -3790,21 +4048,23 @@ Tcl_LsortObjCmd(
* The unified list of SortElement structures.
*
* Side effects:
- * If infoPtr->unique is set then infoPtr->numElements may be updated.
+ * If infoPtr->unique is set then infoPtr->numElements may be updated.
* Possibly others, if a user-defined comparison command does something
- * weird.
+ * weird.
*
* Note:
- * If infoPtr->unique is set, the merge assumes that there are no
+ * If infoPtr->unique is set, the merge assumes that there are no
* "repeated" elements in each of the left and right lists. In that case,
* if any element of the left list is equivalent to one in the right list
* it is omitted from the merged list.
- * This simplified mechanism works because of the special way
- * our MergeSort creates the sublists to be merged and will fail to
- * eliminate all repeats in the general case where they are already
- * present in either the left or right list. A general code would need to
- * skip adjacent initial repeats in the left and right lists before
- * comparing their initial elements, at each step.
+ *
+ * This simplified mechanism works because of the special way our
+ * MergeSort creates the sublists to be merged and will fail to eliminate
+ * all repeats in the general case where they are already present in
+ * either the left or right list. A general code would need to skip
+ * adjacent initial repeats in the left and right lists before comparing
+ * their initial elements, at each step.
+ *
*----------------------------------------------------------------------
*/
@@ -3906,25 +4166,25 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = strcmp(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
- order = strcasecmp(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = strcasecmp(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
- order = DictionaryCompare(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
long a, b;
- a = elemPtr1->index.intValue;
- b = elemPtr2->index.intValue;
+ a = elemPtr1->collationKey.intValue;
+ b = elemPtr2->collationKey.intValue;
order = ((a >= b) - (a <= b));
} else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
- a = elemPtr1->index.doubleValue;
- b = elemPtr2->index.doubleValue;
+ a = elemPtr1->collationKey.doubleValue;
+ b = elemPtr2->collationKey.doubleValue;
order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
@@ -3936,14 +4196,14 @@ SortCompare(
* Once an error has occurred, skip any future comparisons so as
* to preserve the error message in sortInterp->result.
*/
-
+
return 0;
}
- objPtr1 = elemPtr1->index.objValuePtr;
- objPtr2 = elemPtr2->index.objValuePtr;
-
+ objPtr1 = elemPtr1->collationKey.objValuePtr;
+ objPtr2 = elemPtr2->collationKey.objValuePtr;
+
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
@@ -3961,8 +4221,7 @@ SortCompare(
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
if (infoPtr->resultCode != TCL_OK) {
- Tcl_AddErrorInfo(infoPtr->interp,
- "\n (-compare command)");
+ Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)");
return 0;
}
@@ -3975,6 +4234,8 @@ SortCompare(
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendResult(infoPtr->interp,
"-compare command returned non-integer result", NULL);
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "COMPARISONFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
@@ -4011,7 +4272,7 @@ SortCompare(
static int
DictionaryCompare(
- char *left, char *right) /* The strings to compare. */
+ const char *left, const char *right) /* The strings to compare. */
{
Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
int diff, zeros;
@@ -4028,11 +4289,11 @@ DictionaryCompare(
*/
zeros = 0;
- while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
+ while ((*right == '0') && isdigit(UCHAR(right[1]))) {
right++;
zeros--;
}
- while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
+ while ((*left == '0') && isdigit(UCHAR(left[1]))) {
left++;
zeros++;
}
@@ -4191,6 +4452,8 @@ SelectObjFromSublist(
Tcl_AppendResult(infoPtr->interp, "element ", buffer,
" missing from sublist \"", TclGetString(objPtr), "\"",
NULL);
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4204,5 +4467,7 @@ SelectObjFromSublist(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 5390cf0..c34ce6c 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -10,7 +10,7 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
* Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2003 Donal K. Fellows.
+ * Copyright (c) 2003-2009 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,8 +19,27 @@
#include "tclInt.h"
#include "tclRegexp.h"
+static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode,
+ Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
+static int SwitchPostProc(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TryPostBody(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TryPostFinal(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TryPostHandler(ClientData data[], Tcl_Interp *interp,
+ int result);
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
+
+/*
+ * Default set of characters to trim in [string trim] and friends. This is a
+ * UTF-8 literal string containing space, tab, newline, carriage return,
+ * ethiopic wordspace (U+1361), ogham space mark (U+1680), and ideographic
+ * space (U+3000). [TIP #318]
+ */
+
+#define DEFAULT_TRIM_SET " \t\n\r\xe1\x8d\xa1\xe1\x9a\x80\xe3\x80\x80"
/*
*----------------------------------------------------------------------
@@ -44,7 +63,7 @@ Tcl_PwdObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *retVal;
@@ -84,14 +103,14 @@ Tcl_RegexpObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength, matchLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
Tcl_RegExpInfo info;
- static CONST char *options[] = {
+ static const char *const options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
@@ -105,13 +124,12 @@ Tcl_RegexpObjCmd(
indices = 0;
about = 0;
cflags = TCL_REG_ADVANCED;
- eflags = 0;
offset = 0;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
- char *name;
+ const char *name;
int index;
name = TclGetString(objv[i]);
@@ -174,7 +192,7 @@ Tcl_RegexpObjCmd(
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ "?-switch ...? exp string ?matchVar? ?subMatchVar ...?");
goto optionError;
}
objc -= i;
@@ -265,7 +283,7 @@ Tcl_RegexpObjCmd(
*/
if ((offset == 0) || ((offset > 0) &&
- (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n'))) {
+ (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar) '\n'))) {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
@@ -365,11 +383,8 @@ Tcl_RegexpObjCmd(
return TCL_ERROR;
}
} else {
- Tcl_Obj *valuePtr;
- valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
- if (valuePtr == NULL) {
- Tcl_AppendResult(interp, "couldn't set variable \"",
- TclGetString(objv[i]), "\"", NULL);
+ if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
@@ -389,7 +404,8 @@ Tcl_RegexpObjCmd(
* offset never changes).
*/
- matchLength = info.matches[0].end - info.matches[0].start;
+ matchLength = (info.matches[0].end - info.matches[0].start);
+
offset += info.matches[0].end;
/*
@@ -442,7 +458,7 @@ Tcl_RegsubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match;
@@ -451,7 +467,7 @@ Tcl_RegsubObjCmd(
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
- static CONST char *options[] = {
+ static const char *const options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
@@ -468,7 +484,7 @@ Tcl_RegsubObjCmd(
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
- char *name;
+ const char *name;
int index;
name = TclGetString(objv[idx]);
@@ -522,7 +538,7 @@ Tcl_RegsubObjCmd(
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string subSpec ?varName?");
+ "?-switch ...? exp string subSpec ?varName?");
optionError:
if (startIndex) {
Tcl_DecrRefCount(startIndex);
@@ -552,7 +568,7 @@ Tcl_RegsubObjCmd(
*/
int slen, nocase;
- int (*strCmpFn)(CONST Tcl_UniChar*,CONST Tcl_UniChar*,unsigned long);
+ int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long);
Tcl_UniChar *p, wsrclc;
numMatches = 0;
@@ -796,9 +812,8 @@ Tcl_RegsubObjCmd(
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
if (objc == 4) {
- if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
- Tcl_AppendResult(interp, "couldn't set variable \"",
- TclGetString(objv[3]), "\"", NULL);
+ if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
} else {
/*
@@ -851,9 +866,9 @@ Tcl_RenameObjCmd(
ClientData dummy, /* Arbitrary value passed to the command. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *oldName, *newName;
+ const char *oldName, *newName;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
@@ -887,7 +902,7 @@ Tcl_ReturnObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int code, level;
Tcl_Obj *returnOpts;
@@ -934,9 +949,19 @@ Tcl_SourceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- CONST char *encodingName = NULL;
+ return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRSourceObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *encodingName = NULL;
Tcl_Obj *fileName;
if (objc != 2 && objc !=4) {
@@ -947,7 +972,7 @@ Tcl_SourceObjCmd(
fileName = objv[objc-1];
if (objc == 4) {
- static CONST char *options[] = {
+ static const char *const options[] = {
"-encoding", NULL
};
int index;
@@ -959,7 +984,7 @@ Tcl_SourceObjCmd(
encodingName = TclGetString(objv[2]);
}
- return Tcl_FSEvalFileEx(interp, fileName, encodingName);
+ return TclNREvalFile(interp, fileName, encodingName);
}
/*
@@ -984,11 +1009,13 @@ Tcl_SplitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch;
int len;
- char *splitChars, *stringPtr, *end;
+ const char *splitChars;
+ const char *stringPtr;
+ const char *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
@@ -1033,7 +1060,8 @@ Tcl_SplitObjCmd(
* Assume Tcl_UniChar is an integral type...
*/
- hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch),
+ &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1041,9 +1069,9 @@ Tcl_SplitObjCmd(
* Don't need to fiddle with refcount...
*/
- Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+ Tcl_SetHashValue(hPtr, objPtr);
} else {
- objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ objPtr = Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
@@ -1066,7 +1094,7 @@ Tcl_SplitObjCmd(
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
- char *element, *p, *splitEnd;
+ const char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
@@ -1103,7 +1131,8 @@ Tcl_SplitObjCmd(
* StringFirstCmd --
*
* This procedure is invoked to process the "string first" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. Note that this
+ * command only functions correctly on properly formed Tcl UTF strings.
*
* Results:
* A standard Tcl result.
@@ -1121,8 +1150,8 @@ StringFirstCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring1, *ustring2;
- int match, start, length1, length2;
+ Tcl_UniChar *needleStr, *haystackStr;
+ int match, start, needleLen, haystackLen;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1131,15 +1160,15 @@ StringFirstCmd(
}
/*
- * We are searching string2 for the sequence string1.
+ * We are searching haystackStr for the sequence needleStr.
*/
match = -1;
start = 0;
- length2 = -1;
+ haystackLen = -1;
- ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2);
+ needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
+ haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (objc == 4) {
/*
@@ -1147,7 +1176,8 @@ StringFirstCmd(
* point in the string before we think about a match.
*/
- if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
+ &start) != TCL_OK){
return TCL_ERROR;
}
@@ -1155,14 +1185,14 @@ StringFirstCmd(
* Reread to prevent shimmering problems.
*/
- ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2);
+ needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
+ haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
- if (start >= length2) {
+ if (start >= haystackLen) {
goto str_first_done;
} else if (start > 0) {
- ustring2 += start;
- length2 -= start;
+ haystackStr += start;
+ haystackLen -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start; Bug #423581
@@ -1177,18 +1207,18 @@ StringFirstCmd(
* cannot be contained in there so we can avoid searching. [Bug 2960021]
*/
- if (length1 > 0 && length1 <= length2) {
+ if (needleLen > 0 && needleLen <= haystackLen) {
register Tcl_UniChar *p, *end;
- end = ustring2 + length2 - length1 + 1;
- for (p = ustring2; p < end; p++) {
+ end = haystackStr + haystackLen - needleLen + 1;
+ for (p = haystackStr; p < end; p++) {
/*
* Scan forward to find the first character.
*/
- if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p,
- (unsigned long) length1) == 0)) {
- match = p - ustring2;
+ if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p,
+ (unsigned long) needleLen) == 0)) {
+ match = p - haystackStr;
break;
}
}
@@ -1214,7 +1244,8 @@ StringFirstCmd(
* StringLastCmd --
*
* This procedure is invoked to process the "string last" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. Note that this
+ * command only functions correctly on properly formed Tcl UTF strings.
*
* Results:
* A standard Tcl result.
@@ -1232,8 +1263,8 @@ StringLastCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring1, *ustring2, *p;
- int match, start, length1, length2;
+ Tcl_UniChar *needleStr, *haystackStr, *p;
+ int match, start, needleLen, haystackLen;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1242,15 +1273,15 @@ StringLastCmd(
}
/*
- * We are searching string2 for the sequence string1.
+ * We are searching haystackString for the sequence needleString.
*/
match = -1;
start = 0;
- length2 = -1;
+ haystackLen = -1;
- ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2);
+ needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
+ haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (objc == 4) {
/*
@@ -1258,7 +1289,8 @@ StringLastCmd(
* range to that char index in the string
*/
- if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
+ &start) != TCL_OK){
return TCL_ERROR;
}
@@ -1266,18 +1298,18 @@ StringLastCmd(
* Reread to prevent shimmering problems.
*/
- ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2);
+ needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
+ haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (start < 0) {
goto str_last_done;
- } else if (start < length2) {
- p = ustring2 + start + 1 - length1;
+ } else if (start < haystackLen) {
+ p = haystackStr + start + 1 - needleLen;
} else {
- p = ustring2 + length2 - length1;
+ p = haystackStr + haystackLen - needleLen;
}
} else {
- p = ustring2 + length2 - length1;
+ p = haystackStr + haystackLen - needleLen;
}
/*
@@ -1285,15 +1317,15 @@ StringLastCmd(
* cannot be contained in there so we can avoid searching. [Bug 2960021]
*/
- if (length1 > 0 && length1 <= length2) {
- for (; p >= ustring2; p--) {
+ if (needleLen > 0 && needleLen <= haystackLen) {
+ for (; p >= haystackStr; p--) {
/*
* Scan backwards to find the first character.
*/
- if ((*p == *ustring1) && !memcmp(ustring1, p,
- sizeof(Tcl_UniChar) * (size_t)length1)) {
- match = p - ustring2;
+ if ((*p == *needleStr) && !memcmp(needleStr, p,
+ sizeof(Tcl_UniChar) * (size_t)needleLen)) {
+ match = p - haystackStr;
break;
}
}
@@ -1337,37 +1369,29 @@ StringIndexCmd(
}
/*
- * If we have a ByteArray object, avoid indexing in the Utf string since
- * the byte array contains one byte per character. Otherwise, use the
- * Unicode string rep to get the index'th char.
+ * Get the char length to calulate what 'end' means.
*/
- if (objv[1]->typePtr == &tclByteArrayType) {
- const unsigned char *string =
- Tcl_GetByteArrayFromObj(objv[1], &length);
+ length = Tcl_GetCharLength(objv[1]);
+ if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if ((index >= 0) && (index < length)) {
+ Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index);
- if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){
- return TCL_ERROR;
- }
- string = Tcl_GetByteArrayFromObj(objv[1], &length);
- if ((index >= 0) && (index < length)) {
- Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1));
- }
- } else {
/*
- * Get Unicode char length to calulate what 'end' means.
+ * If we have a ByteArray object, we're careful to generate a new
+ * bytearray for a result.
*/
- length = Tcl_GetCharLength(objv[1]);
+ if (TclIsPureByteArray(objv[1])) {
+ unsigned char uch = (unsigned char) ch;
- if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){
- return TCL_ERROR;
- }
- if ((index >= 0) && (index < length)) {
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
+ } else {
char buf[TCL_UTF_MAX];
- Tcl_UniChar ch;
- ch = Tcl_GetUniChar(objv[1], index);
length = Tcl_UniCharToUtf(ch, buf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
}
@@ -1407,7 +1431,7 @@ StringIsCmd(
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
- static const char *isClasses[] = {
+ static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "false",
"graph", "integer", "list", "lower",
@@ -1419,10 +1443,10 @@ StringIsCmd(
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER,
- STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE,
+ STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE,
STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
- static const char *isOptions[] = {
+ static const char *const isOptions[] = {
"-strict", "-failindex", NULL
};
enum isOptions {
@@ -1536,7 +1560,6 @@ StringIsCmd(
if (stop < end) {
result = 0;
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
}
}
break;
@@ -1593,7 +1616,6 @@ StringIsCmd(
failat = stop - string1;
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
}
} else {
/*
@@ -1770,6 +1792,8 @@ StringMapCmd(
} else {
Tcl_AppendResult(interp, "bad option \"", string,
"\": must be -nocase", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+ string, NULL);
return TCL_ERROR;
}
}
@@ -1806,8 +1830,7 @@ StringMapCmd(
* adapt this code...
*/
- mapElemv = (Tcl_Obj **)
- TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
+ mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (i=2 ; i<mapElemc ; i+=2) {
@@ -1833,6 +1856,8 @@ StringMapCmd(
Tcl_SetObjResult(interp,
Tcl_NewStringObj("char map list unbalanced", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
+ "UNBALANCED", NULL);
return TCL_ERROR;
}
}
@@ -1916,12 +1941,10 @@ StringMapCmd(
* case.
*/
- mapStrings = (Tcl_UniChar **) TclStackAlloc(interp,
- mapElemc * 2 * sizeof(Tcl_UniChar *));
- mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
+ mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
+ mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
if (nocase) {
- u2lc = (Tcl_UniChar *) TclStackAlloc(interp,
- mapElemc * sizeof(Tcl_UniChar));
+ u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
@@ -2036,6 +2059,8 @@ StringMatchCmd(
} else {
Tcl_AppendResult(interp, "bad option \"", string,
"\": must be -nocase", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+ string, NULL);
return TCL_ERROR;
}
}
@@ -2069,7 +2094,6 @@ StringRangeCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const unsigned char *string;
int length, first, last;
if (objc != 4) {
@@ -2078,22 +2102,11 @@ StringRangeCmd(
}
/*
- * If we have a ByteArray object, avoid indexing in the Utf string since
- * the byte array contains one byte per character. Otherwise, use the
- * Unicode string rep to get the range.
+ * Get the length in actual characters; Then reduce it by one because
+ * 'end' refers to the last character, not one past it.
*/
- if (objv[1]->typePtr == &tclByteArrayType) {
- string = Tcl_GetByteArrayFromObj(objv[1], &length);
- length--;
- } else {
- /*
- * Get the length in actual characters.
- */
-
- string = NULL;
- length = Tcl_GetCharLength(objv[1]) - 1;
- }
+ length = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) {
@@ -2107,17 +2120,7 @@ StringRangeCmd(
last = length;
}
if (last >= first) {
- if (string != NULL) {
- /*
- * Reread the string to prevent shimmering nasties.
- */
-
- string = Tcl_GetByteArrayFromObj(objv[1], &length);
- Tcl_SetObjResult(interp,
- Tcl_NewByteArrayObj(string+first, last - first + 1));
- } else {
- Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
- }
+ Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
}
return TCL_OK;
}
@@ -2186,9 +2189,11 @@ StringReptCmd(
* We need to keep 2 <= length2 <= INT_MAX.
*/
- if (count > (INT_MAX / length1)) {
+ if (count > INT_MAX/length1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "result exceeds max size for a Tcl value (%d bytes)", INT_MAX));
+ "result exceeds max size for a Tcl value (%d bytes)",
+ INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
length2 = length1 * count;
@@ -2209,6 +2214,7 @@ StringReptCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow, out of memory allocating %u bytes",
length2 + 1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
for (index = 0; index < count; index++) {
@@ -2486,7 +2492,7 @@ StringEqualCmd(
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
- char *string1, *string2;
+ const char *string1, *string2;
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
@@ -2507,13 +2513,15 @@ StringEqualCmd(
if (i+1 >= objc-2) {
goto str_cmp_args;
}
- ++i;
+ i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendResult(interp, "bad option \"", string2,
"\": must be -nocase or -length", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+ string2, NULL);
return TCL_ERROR;
}
}
@@ -2534,8 +2542,8 @@ StringEqualCmd(
return TCL_OK;
}
- if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
- objv[1]->typePtr == &tclByteArrayType) {
+ if (!nocase && TclIsPureByteArray(objv[0]) &&
+ TclIsPureByteArray(objv[1])) {
/*
* Use binary versions of comparisons since that won't cause undue
* type conversions and it is much faster. Only do this if we're
@@ -2633,7 +2641,7 @@ StringCmpCmd(
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
- char *string1, *string2;
+ const char *string1, *string2;
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
@@ -2654,13 +2662,15 @@ StringCmpCmd(
if (i+1 >= objc-2) {
goto str_cmp_args;
}
- ++i;
+ i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendResult(interp, "bad option \"", string2,
"\": must be -nocase or -length", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+ string2, NULL);
return TCL_ERROR;
}
}
@@ -2681,8 +2691,8 @@ StringCmpCmd(
return TCL_OK;
}
- if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
- objv[1]->typePtr == &tclByteArrayType) {
+ if (!nocase && TclIsPureByteArray(objv[0]) &&
+ TclIsPureByteArray(objv[1])) {
/*
* Use binary versions of comparisons since that won't cause undue
* type conversions and it is much faster. Only do this if we're
@@ -2809,25 +2819,12 @@ StringLenCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length;
-
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
- /*
- * If we have a ByteArray object, avoid recomputing the string since the
- * byte array contains one byte per character. Otherwise, use the Unicode
- * string rep to calculate the length.
- */
-
- if (objv[1]->typePtr == &tclByteArrayType) {
- (void) Tcl_GetByteArrayFromObj(objv[1], &length);
- } else {
- length = Tcl_GetCharLength(objv[1]);
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1])));
return TCL_OK;
}
@@ -2857,7 +2854,8 @@ StringLowerCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
- char *string1, *string2;
+ const char *string1;
+ char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
@@ -2941,7 +2939,8 @@ StringUpperCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
- char *string1, *string2;
+ const char *string1;
+ char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
@@ -3025,7 +3024,8 @@ StringTitleCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
- char *string1, *string2;
+ const char *string1;
+ char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
@@ -3114,8 +3114,8 @@ StringTrimCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3162,8 +3162,8 @@ StringTrimLCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3208,8 +3208,8 @@ StringTrimRCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3250,29 +3250,29 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
- {"bytelength", StringBytesCmd, NULL},
- {"compare", StringCmpCmd, TclCompileStringCmpCmd},
- {"equal", StringEqualCmd, TclCompileStringEqualCmd},
- {"first", StringFirstCmd, NULL},
- {"index", StringIndexCmd, TclCompileStringIndexCmd},
- {"is", StringIsCmd, NULL},
- {"last", StringLastCmd, NULL},
- {"length", StringLenCmd, TclCompileStringLenCmd},
- {"map", StringMapCmd, NULL},
- {"match", StringMatchCmd, TclCompileStringMatchCmd},
- {"range", StringRangeCmd, NULL},
- {"repeat", StringReptCmd, NULL},
- {"replace", StringRplcCmd, NULL},
- {"reverse", StringRevCmd, NULL},
- {"tolower", StringLowerCmd, NULL},
- {"toupper", StringUpperCmd, NULL},
- {"totitle", StringTitleCmd, NULL},
- {"trim", StringTrimCmd, NULL},
- {"trimleft", StringTrimLCmd, NULL},
- {"trimright", StringTrimRCmd, NULL},
- {"wordend", StringEndCmd, NULL},
- {"wordstart", StringStartCmd, NULL},
- {NULL}
+ {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0},
+ {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
+ {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
+ {"first", StringFirstCmd, NULL, NULL, NULL, 0},
+ {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
+ {"is", StringIsCmd, NULL, NULL, NULL, 0},
+ {"last", StringLastCmd, NULL, NULL, NULL, 0},
+ {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
+ {"map", StringMapCmd, NULL, NULL, NULL, 0},
+ {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
+ {"range", StringRangeCmd, NULL, 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},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "string", stringImplMap);
@@ -3297,30 +3297,24 @@ TclInitStringCmd(
*/
int
-Tcl_SubstObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+TclSubstOptions(
+ Tcl_Interp *interp,
+ int numOpts,
+ Tcl_Obj *const opts[],
+ int *flagPtr)
{
- static CONST char *substOptions[] = {
+ static const char *const substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", NULL
};
- enum substOptions {
+ enum {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
- Tcl_Obj *resultPtr;
- int flags, i;
+ int i, flags = TCL_SUBST_ALL;
- /*
- * Parse command-line options.
- */
-
- flags = TCL_SUBST_ALL;
- for (i = 1; i < (objc-1); i++) {
+ for (i = 0; i < numOpts; i++) {
int optionIndex;
- if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0,
+ if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -3338,23 +3332,39 @@ Tcl_SubstObjCmd(
Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
}
}
- if (i != objc-1) {
+ *flagPtr = flags;
+ return TCL_OK;
+}
+
+int
+Tcl_SubstObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRSubstObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int flags;
+
+ if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
- /*
- * Perform the substitution.
- */
-
- resultPtr = Tcl_SubstObj(interp, objv[i], flags);
-
- if (resultPtr == NULL) {
+ if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
+ return Tcl_NRSubstObj(interp, objv[objc-1], flags);
}
/*
@@ -3379,13 +3389,22 @@ Tcl_SwitchObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv);
+}
+int
+TclNRSwitchObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved;
+ int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
int noCase, patternLength;
- char *pattern;
+ const char *pattern;
Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
- Tcl_Obj *CONST *savedObjv = objv;
+ Tcl_Obj *const *savedObjv = objv;
Tcl_RegExp regExpr = NULL;
Interp *iPtr = (Interp *) interp;
int pc = 0;
@@ -3399,7 +3418,7 @@ Tcl_SwitchObjCmd(
* -glob, you *must* fix TclCompileSwitchCmd's option parser as well.
*/
- static CONST char *options[] = {
+ static const char *const options[] = {
"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
"--", NULL
};
@@ -3450,12 +3469,13 @@ Tcl_SwitchObjCmd(
Tcl_AppendResult(interp, "bad option \"",
TclGetString(objv[i]), "\": ", options[mode],
" option already found", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "DOUBLEOPT", NULL);
return TCL_ERROR;
- } else {
- foundmode = 1;
- mode = index;
- break;
}
+ foundmode = 1;
+ mode = index;
+ break;
/*
* Check for TIP#75 options specifying the variables to write
@@ -3467,6 +3487,8 @@ Tcl_SwitchObjCmd(
if (i >= objc-2) {
Tcl_AppendResult(interp, "missing variable name argument to ",
"-indexvar", " option", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "NOVAR", NULL);
return TCL_ERROR;
}
indexVarObj = objv[i];
@@ -3477,6 +3499,8 @@ Tcl_SwitchObjCmd(
if (i >= objc-2) {
Tcl_AppendResult(interp, "missing variable name argument to ",
"-matchvar", " option", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "NOVAR", NULL);
return TCL_ERROR;
}
matchVarObj = objv[i];
@@ -3488,17 +3512,21 @@ Tcl_SwitchObjCmd(
finishedOptions:
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? string pattern body ... ?default body?");
+ "?-switch ...? string ?pattern body ...? ?default body?");
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
Tcl_AppendResult(interp,
"-indexvar option requires -regexp option", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "MODERESTRICTION", NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
Tcl_AppendResult(interp,
"-matchvar option requires -regexp option", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "MODERESTRICTION", NULL);
return TCL_ERROR;
}
@@ -3519,8 +3547,8 @@ Tcl_SwitchObjCmd(
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
- blist = objv[0];
+ blist = objv[0];
if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
return TCL_ERROR;
}
@@ -3531,7 +3559,7 @@ Tcl_SwitchObjCmd(
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
- "?switches? string {pattern body ... ?default body?}");
+ "?-switch ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
objv = listv;
@@ -3546,6 +3574,8 @@ Tcl_SwitchObjCmd(
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
+ NULL);
/*
* Check if this can be due to a badly placed comment in the switch
@@ -3562,6 +3592,8 @@ Tcl_SwitchObjCmd(
"comment incorrectly placed outside of a "
"switch body - see the \"switch\" "
"documentation", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+ "BADARM", "COMMENT?", NULL);
break;
}
}
@@ -3579,6 +3611,8 @@ Tcl_SwitchObjCmd(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "no body specified for pattern \"",
TclGetString(objv[objc-2]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
+ "FALLTHROUGH", NULL);
return TCL_ERROR;
}
@@ -3617,36 +3651,35 @@ Tcl_SwitchObjCmd(
}
}
goto matchFound;
- } else {
- switch (mode) {
- case OPT_EXACT:
- if (strCmpFn(TclGetString(stringObj), pattern) == 0) {
- goto matchFound;
- }
- break;
- case OPT_GLOB:
- if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern,
- noCase)) {
- goto matchFound;
- }
- break;
- case OPT_REGEXP:
- regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
- TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
- if (regExpr == NULL) {
- return TCL_ERROR;
- } else {
- int matched = Tcl_RegExpExecObj(interp, regExpr,
- stringObj, 0, numMatchesSaved, 0);
+ }
- if (matched < 0) {
- return TCL_ERROR;
- } else if (matched) {
- goto matchFoundRegexp;
- }
+ switch (mode) {
+ case OPT_EXACT:
+ if (strCmpFn(TclGetString(stringObj), pattern) == 0) {
+ goto matchFound;
+ }
+ break;
+ case OPT_GLOB:
+ if (Tcl_StringCaseMatch(TclGetString(stringObj),pattern,noCase)) {
+ goto matchFound;
+ }
+ break;
+ case OPT_REGEXP:
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
+ TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ } else {
+ int matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0,
+ numMatchesSaved, 0);
+
+ if (matched < 0) {
+ return TCL_ERROR;
+ } else if (matched) {
+ goto matchFoundRegexp;
}
- break;
}
+ break;
}
}
return TCL_OK;
@@ -3738,7 +3771,7 @@ Tcl_SwitchObjCmd(
*/
matchFound:
- ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
@@ -3753,7 +3786,7 @@ Tcl_SwitchObjCmd(
if (ctxPtr->type == TCL_LOCATION_BC) {
/*
* Type BC => ctxPtr->data.eval.path is not used.
- * ctxPtr->data.tebc.codePtr is used instead.
+ * ctxPtr->data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc(ctxPtr);
@@ -3768,7 +3801,7 @@ Tcl_SwitchObjCmd(
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
- ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
+ ctxPtr->line = ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
@@ -3782,7 +3815,7 @@ Tcl_SwitchObjCmd(
int k;
- ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
+ ctxPtr->line = ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
@@ -3808,9 +3841,31 @@ Tcl_SwitchObjCmd(
* TIP #280: Make invoking context available to switch branch.
*/
- result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
+ Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
+ INT2PTR(pc), (ClientData) pattern);
+ return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
+}
+
+static int
+SwitchPostProc(
+ ClientData data[], /* Data passed from Tcl_NRAddCallback above */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ int result) /* Result to return*/
+{
+ /* Unpack the preserved data */
+
+ int splitObjs = PTR2INT(data[0]);
+ CmdFrame *ctxPtr = data[1];
+ int pc = PTR2INT(data[2]);
+ const char *pattern = data[3];
+ int patternLength = strlen(pattern);
+
+ /*
+ * Clean up TIP 280 context information
+ */
+
if (splitObjs) {
- ckfree((char *) ctxPtr->line);
+ ckfree(ctxPtr->line);
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
/*
* Death of SrcInfo reference.
@@ -3831,7 +3886,7 @@ Tcl_SwitchObjCmd(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s%s\" arm line %d)",
(overflow ? limit : patternLength), pattern,
- (overflow ? "..." : ""), interp->errorLine));
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
TclStackFree(interp, ctxPtr);
return result;
@@ -3840,6 +3895,68 @@ Tcl_SwitchObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_ThrowObjCmd --
+ *
+ * This procedure is invoked to process the "throw" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_ThrowObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *options;
+ int len;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type message");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The type must be a list of at least length 1.
+ */
+
+ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ return TCL_ERROR;
+ } else if (len < 1) {
+ Tcl_AppendResult(interp, "type must be non-empty list", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now prepare the result options dictionary. We use the list API as it is
+ * slightly more convenient.
+ */
+
+ TclNewLiteralStringObj(options, "-code error -level 0 -errorcode");
+ Tcl_ListObjAppendElement(NULL, options, objv[1]);
+
+ /*
+ * We're ready to go. Fire things into the low-level result machinery.
+ */
+
+ Tcl_SetObjResult(interp, objv[2]);
+ return Tcl_SetReturnOptions(interp, options);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_TimeObjCmd --
*
* This object-based procedure is invoked to process the "time" Tcl
@@ -3859,7 +3976,7 @@ Tcl_TimeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
@@ -3932,6 +4049,576 @@ Tcl_TimeObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_TryObjCmd, TclNRTryObjCmd --
+ *
+ * This procedure is invoked to process the "try" Tcl command. See the
+ * user documentation (or TIP #329) for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TryObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRTryObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
+ int i, bodyShared, haveHandlers, dummy, code;
+ static const char *const handlerNames[] = {
+ "finally", "on", "trap", NULL
+ };
+ enum Handlers {
+ TryFinally, TryOn, TryTrap
+ };
+
+ /*
+ * Parse the arguments. The handlers are passed to subsequent callbacks as
+ * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix,
+ * bindVariables, script), and the finally script is just passed as it is.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "body ?handler ...? ?finally script?");
+ return TCL_ERROR;
+ }
+ bodyObj = objv[1];
+ handlersObj = Tcl_NewObj();
+ bodyShared = 0;
+ haveHandlers = 0;
+ for (i=2 ; i<objc ; i++) {
+ int type;
+ Tcl_Obj *info[5];
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
+ 0, &type) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ switch ((enum Handlers) type) {
+ case TryFinally: /* finally script */
+ if (i < objc-2) {
+ Tcl_AppendResult(interp, "finally clause must be last", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+ "NONTERMINAL", NULL);
+ return TCL_ERROR;
+ } else if (i == objc-1) {
+ Tcl_AppendResult(interp, "wrong # args to finally clause: ",
+ "must be \"", TclGetString(objv[0]),
+ " ... finally script\"", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ finallyObj = objv[++i];
+ break;
+
+ case TryOn: /* on code variableList script */
+ if (i > objc-4) {
+ Tcl_AppendResult(interp, "wrong # args to on clause: ",
+ "must be \"", TclGetString(objv[0]),
+ " ... on code variableList script\"", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ info[2] = NULL;
+ goto commonHandler;
+
+ case TryTrap: /* trap pattern variableList script */
+ if (i > objc-4) {
+ Tcl_AppendResult(interp, "wrong # args to trap clause: ",
+ "must be \"... trap pattern variableList script\"",
+ NULL);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ code = 1;
+ if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad prefix '%s': must be a list",
+ Tcl_GetString(objv[i+1])));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+ "EXNFORMAT", NULL);
+ return TCL_ERROR;
+ }
+ info[2] = objv[i+1];
+
+ commonHandler:
+ if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+
+ info[0] = objv[i]; /* type */
+ TclNewIntObj(info[1], code); /* returnCode */
+ if (info[2] == NULL) { /* errorCodePrefix */
+ TclNewObj(info[2]);
+ }
+ info[3] = objv[i+2]; /* bindVariables */
+ info[4] = objv[i+3]; /* script */
+
+ bodyShared = !strcmp(TclGetString(objv[i+3]), "-");
+ Tcl_ListObjAppendElement(NULL, handlersObj,
+ Tcl_NewListObj(5, info));
+ haveHandlers = 1;
+ i += 3;
+ break;
+ }
+ }
+ if (bodyShared) {
+ Tcl_AppendResult(interp,
+ "last non-finally clause must not have a body of \"-\"",
+ NULL);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (!haveHandlers) {
+ Tcl_DecrRefCount(handlersObj);
+ handlersObj = NULL;
+ }
+
+ /*
+ * Execute the body.
+ */
+
+ Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
+ (ClientData)objv, INT2PTR(objc));
+ return TclNREvalObjEx(interp, bodyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * During --
+ *
+ * This helper function patches together the updates to the interpreter's
+ * return options that are needed when things fail during the processing
+ * of a handler or finally script for the [try] command.
+ *
+ * Returns:
+ * The new option dictionary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline Tcl_Obj *
+During(
+ Tcl_Interp *interp,
+ int resultCode, /* The result code from the just-evaluated
+ * script. */
+ Tcl_Obj *oldOptions, /* The old option dictionary. */
+ Tcl_Obj *errorInfo) /* An object to append to the errorinfo and
+ * release, or NULL if nothing is to be added.
+ * Designed to be used with Tcl_ObjPrintf. */
+{
+ Tcl_Obj *during, *options;
+
+ if (errorInfo != NULL) {
+ Tcl_AppendObjToErrorInfo(interp, errorInfo);
+ }
+ options = Tcl_GetReturnOptions(interp, resultCode);
+ TclNewLiteralStringObj(during, "-during");
+ Tcl_IncrRefCount(during);
+ Tcl_DictObjPut(interp, options, during, oldOptions);
+ Tcl_DecrRefCount(during);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(oldOptions);
+ return options;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostBody --
+ *
+ * Callback to handle the outcome of the execution of the body of a 'try'
+ * command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostBody(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
+ int i, dummy, code, objc;
+ int numHandlers = 0;
+
+ handlersObj = data[0];
+ finallyObj = data[1];
+ objv = data[2];
+ objc = PTR2INT(data[3]);
+
+ cmdObj = objv[0];
+
+ /*
+ * Check for limits/rewinding, which override normal trapping behaviour.
+ */
+
+ if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%s\" body line %d)", TclGetString(cmdObj),
+ Tcl_GetErrorLine(interp)));
+ if (handlersObj != NULL) {
+ Tcl_DecrRefCount(handlersObj);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Basic processing of the outcome of the script, including adding of
+ * errorinfo trace.
+ */
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%s\" body line %d)", TclGetString(cmdObj),
+ Tcl_GetErrorLine(interp)));
+ }
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ Tcl_ResetResult(interp);
+
+ /*
+ * Handle the results.
+ */
+
+ if (handlersObj != NULL) {
+ int found = 0;
+ Tcl_Obj **handlers, **info;
+
+ Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+ for (i=0 ; i<numHandlers ; i++) {
+ Tcl_Obj *handlerBodyObj;
+
+ Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info);
+ if (!found) {
+ Tcl_GetIntFromObj(NULL, info[1], &code);
+ if (code != result) {
+ continue;
+ }
+
+ /*
+ * When processing an error, we must also perform list-prefix
+ * matching of the errorcode list. However, if this was an
+ * 'on' handler, the list that we are matching against will be
+ * empty.
+ */
+
+ if (code == TCL_ERROR) {
+ Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
+ int len1, len2, j;
+
+ TclNewLiteralStringObj(errorCodeName, "-errorcode");
+ Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
+ Tcl_DecrRefCount(errorCodeName);
+ Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1);
+ if (Tcl_ListObjGetElements(NULL, errcode, &len2,
+ &bits2) != TCL_OK) {
+ continue;
+ }
+ if (len2 < len1) {
+ continue;
+ }
+ for (j=0 ; j<len1 ; j++) {
+ if (strcmp(TclGetString(bits1[j]),
+ TclGetString(bits2[j])) != 0) {
+ /*
+ * Really want 'continue outerloop;', but C does
+ * not give us that.
+ */
+
+ goto didNotMatch;
+ }
+ }
+ }
+
+ found = 1;
+ }
+
+ /*
+ * Now we need to scan forward over "-" bodies. Note that we've
+ * already checked that the last body is not a "-", so this search
+ * will terminate successfully.
+ */
+
+ if (!strcmp(TclGetString(info[4]), "-")) {
+ continue;
+ }
+
+ /*
+ * Bind the variables. We already know this is a list of variable
+ * names, but it might be empty.
+ */
+
+ Tcl_ResetResult(interp);
+ result = TCL_ERROR;
+ Tcl_ListObjLength(NULL, info[3], &dummy);
+ if (dummy > 0) {
+ Tcl_Obj *varName;
+
+ Tcl_ListObjIndex(NULL, info[3], 0, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(resultObj);
+ goto handlerFailed;
+ }
+ Tcl_DecrRefCount(resultObj);
+ if (dummy > 1) {
+ Tcl_ListObjIndex(NULL, info[3], 1, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, options,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ goto handlerFailed;
+ }
+ }
+ } else {
+ /*
+ * Dispose of the result to prevent a memleak. [Bug 2910044]
+ */
+
+ Tcl_DecrRefCount(resultObj);
+ }
+
+ /*
+ * Evaluate the handler body and process the outcome. Note that we
+ * need to keep the kind of handler for debugging purposes, and in
+ * any case anything we want from info[] must be extracted right
+ * now because the info[] array is about to become invalid. There
+ * is very little refcount handling here however, since we know
+ * that the objects that we still want to refer to now were input
+ * arguments to [try] and so are still on the Tcl value stack.
+ */
+
+ handlerBodyObj = info[4];
+ Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0],
+ INT2PTR((finallyObj == NULL) ? 0 : objc - 1));
+ Tcl_DecrRefCount(handlersObj);
+ return TclNREvalObjEx(interp, handlerBodyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, 4*i + 5);
+
+ handlerFailed:
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ options = During(interp, result, options, NULL);
+ break;
+
+ didNotMatch:
+ continue;
+ }
+
+ /*
+ * No handler matched; get rid of the list of handlers.
+ */
+
+ Tcl_DecrRefCount(handlersObj);
+ }
+
+ /*
+ * Process the finally clause.
+ */
+
+ if (finallyObj != NULL) {
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
+ NULL);
+ return TclNREvalObjEx(interp, finallyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, objc - 1);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostHandler --
+ *
+ * Callback to handle the outcome of the execution of a handler of a
+ * 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostHandler(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
+ Tcl_Obj *finallyObj;
+ int finally;
+
+ objv = data[0];
+ options = data[1];
+ handlerKindObj = data[2];
+ finally = PTR2INT(data[3]);
+
+ cmdObj = objv[0];
+ finallyObj = finally ? objv[finally] : 0;
+
+ /*
+ * Check for limits/rewinding, which override normal trapping behaviour.
+ */
+
+ if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... %s\" handler line %d)",
+ TclGetString(cmdObj), TclGetString(handlerKindObj),
+ Tcl_GetErrorLine(interp)));
+ Tcl_DecrRefCount(options);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The handler result completely substitutes for the result of the body.
+ */
+
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... %s\" handler line %d)",
+ TclGetString(cmdObj), TclGetString(handlerKindObj),
+ Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_DecrRefCount(options);
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ }
+
+ /*
+ * Process the finally clause if it is present.
+ */
+
+ if (finallyObj != NULL) {
+ Interp *iPtr = (Interp *) interp;
+
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
+ NULL);
+
+ /* The 'finally' script is always the last argument word. */
+ return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr,
+ finally);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostFinal --
+ *
+ * Callback to handle the outcome of the execution of the finally script
+ * of a 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *options, *cmdObj;
+
+ resultObj = data[0];
+ options = data[1];
+ cmdObj = data[2];
+
+ /*
+ * If the result wasn't OK, we need to adjust the result options.
+ */
+
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(resultObj);
+ resultObj = NULL;
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... finally\" body line %d)",
+ TclGetString(cmdObj), Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_Obj *origOptions = options;
+
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(origOptions);
+ }
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command. See the
@@ -3955,42 +4642,39 @@ Tcl_WhileObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRWhileObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- int result, value;
- Interp *iPtr = (Interp *) interp;
+ ForIterData *iterPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
- while (1) {
- result = Tcl_ExprBooleanObj(interp, objv[1], &value);
- if (result != TCL_OK) {
- return result;
- }
- if (!value) {
- break;
- }
+ /*
+ * We reuse [for]'s callback, passing a NULL for the 'next' script.
+ */
- /* TIP #280. */
- result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2);
- if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
- if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"while\" body line %d)", interp->errorLine));
- }
- break;
- }
- }
- if (result == TCL_BREAK) {
- result = TCL_OK;
- }
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- }
- return result;
+ TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr);
+ iterPtr->cond = objv[1];
+ iterPtr->body = objv[2];
+ iterPtr->next = NULL;
+ iterPtr->msg = "\n (\"while\" body line %d)";
+ iterPtr->word = 2;
+
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
+ NULL, NULL);
+ return TCL_OK;
}
/*
@@ -4011,32 +4695,30 @@ Tcl_WhileObjCmd(
void
TclListLines(
- Tcl_Obj* listObj, /* Pointer to obj holding a string with list
- * structure. Assumed to be valid. Assumed to
- * contain n elements.
- */
+ Tcl_Obj *listObj, /* Pointer to obj holding a string with list
+ * structure. Assumed to be valid. Assumed to
+ * contain n elements. */
int line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
- Tcl_Obj* const* elems) /* The list elems as Tcl_Obj*, in need of
+ Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
- CONST char* listStr = Tcl_GetString (listObj);
- CONST char* listHead = listStr;
+ const char *listStr = Tcl_GetString(listObj);
+ const char *listHead = listStr;
int i, length = strlen(listStr);
- CONST char *element = NULL, *next = NULL;
- ContLineLoc* clLocPtr = TclContinuationsGet(listObj);
- int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
+ const char *element = NULL, *next = NULL;
+ ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
+ int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
for (i = 0; i < n; i++) {
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
TclAdvanceLines(&line, listStr, element);
/* Leading whitespace */
- TclAdvanceContinuations (&line, &clNext, element - listHead);
+ TclAdvanceContinuations(&line, &clNext, element - listHead);
if (elems && clNext) {
- TclContinuationsEnterDerived (elems[i], element - listHead,
- clNext);
+ TclContinuationsEnterDerived(elems[i], element-listHead, clNext);
}
lines[i] = line;
length -= (next - listStr);
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index ddd2242..083f530 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -17,6 +17,31 @@
#include "tclCompile.h"
/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static ClientData DupDictUpdateInfo(ClientData clientData);
+static void FreeDictUpdateInfo(ClientData clientData);
+static void PrintDictUpdateInfo(ClientData clientData,
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static ClientData DupForeachInfo(ClientData clientData);
+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);
+
+/*
* Macro that encapsulates an efficiency trick that avoids a function call for
* the simplest of compiles. The ANSI C "prototype" for this macro is:
*
@@ -25,14 +50,14 @@
*/
#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_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]; \
+ (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)); \
+ (envPtr)); \
}
/*
@@ -45,165 +70,36 @@
*/
#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
+ 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)]
-
-/*
- * Convenience macro for use when compiling bodies of commands. The ANSI C
- * "prototype" for this macro is:
- *
- * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
- */
-
-#define CompileBody(envPtr, tokenPtr, interp) \
- TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr))
-
-/*
- * Convenience macro for use when compiling tokens to be pushed. The ANSI C
- * "prototype" for this macro is:
- *
- * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
- */
-
-#define CompileTokens(envPtr, tokenPtr, interp) \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr));
-/*
- * Convenience macro for use when pushing literals. The ANSI C "prototype" for
- * this macro is:
- *
- * static void PushLiteral(CompileEnv *envPtr,
- * const char *string, int length);
- */
-
-#define PushLiteral(envPtr, string, length) \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
-
-/*
- * Macro to advance to the next token; it is more mnemonic than the address
- * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
- *
- * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
- */
-
-#define TokenAfter(tokenPtr) \
- ((tokenPtr) + ((tokenPtr)->numComponents + 1))
-
-/*
- * Macro to get the offset to the next instruction to be issued. The ANSI C
- * "prototype" for this macro is:
- *
- * static int CurrentOffset(CompileEnv *envPtr);
- */
-
-#define CurrentOffset(envPtr) \
- ((envPtr)->codeNext - (envPtr)->codeStart)
-
-/*
- * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
- * maximal depth of nested CATCH ranges in order to alloc runtime
- * memory. These macros should compute precisely that? OTOH, the nesting depth
- * 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 = \
- TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
- ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
-#define ExceptionRangeEnds(envPtr, index) \
- (((envPtr)->exceptDepth--), \
- ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
- CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
-#define ExceptionRangeTarget(envPtr, index, targetType) \
- ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
-
-/*
- * Prototypes for procedures defined later in this file:
- */
-
-static ClientData DupDictUpdateInfo(ClientData clientData);
-static void FreeDictUpdateInfo(ClientData clientData);
-static void PrintDictUpdateInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static ClientData DupForeachInfo(ClientData clientData);
-static void FreeForeachInfo(ClientData clientData);
-static void PrintForeachInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static ClientData DupJumptableInfo(ClientData clientData);
-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);
-static int CompileComparisonOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static int CompileUnaryOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static void CompileReturnInternal(CompileEnv *envPtr,
- unsigned char op, int code, int level,
- Tcl_Obj *returnOpts);
+ 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)])
+ 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_CREATE_VAR 1 /* Create a compiled local if none is found */
-#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
+#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
*/
-AuxDataType tclForeachInfoType = {
+const AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
DupForeachInfo, /* dupProc */
FreeForeachInfo, /* freeProc */
PrintForeachInfo /* printProc */
};
-AuxDataType tclJumptableInfoType = {
- "JumptableInfo", /* name */
- DupJumptableInfo, /* dupProc */
- FreeJumptableInfo, /* freeProc */
- PrintJumptableInfo /* printProc */
-};
-
-AuxDataType tclDictUpdateInfoType = {
+const AuxDataType tclDictUpdateInfoType = {
"DictUpdateInfo", /* name */
DupDictUpdateInfo, /* dupProc */
FreeDictUpdateInfo, /* freeProc */
@@ -218,8 +114,8 @@ AuxDataType tclDictUpdateInfoType = {
* Procedure called to compile the "append" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "append" command at
@@ -268,8 +164,8 @@ TclCompileAppendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called, so
@@ -319,8 +215,8 @@ TclCompileAppendCmd(
* Procedure called to compile the "break" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "break" command at
@@ -399,7 +295,7 @@ TclCompileCatchCmd(
* (not in a procedure), don't compile it inline: the payoff is too small.
*/
- if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) {
+ if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) {
return TCL_ERROR;
}
@@ -423,7 +319,7 @@ TclCompileCatchCmd(
return TCL_ERROR;
}
resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
- resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
+ resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
@@ -440,7 +336,7 @@ TclCompileCatchCmd(
return TCL_ERROR;
}
optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
- optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
+ optsNameTokenPtr[1].size, /*create*/ 1, envPtr);
if (optsIndex < 0) {
return TCL_ERROR;
}
@@ -495,7 +391,7 @@ TclCompileCatchCmd(
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.
*/
@@ -507,13 +403,13 @@ TclCompileCatchCmd(
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
/*
- * Update the target of the jump after the "no errors" code.
+ * Update the target of the jump after the "no errors" code.
*/
/* Stack at this point: ?script? result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
- (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+ (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
/* Push the return options if the caller wants them */
@@ -571,7 +467,7 @@ TclCompileCatchCmd(
TclEmitOpcode(INST_POP, envPtr);
}
- /*
+ /*
* Stack is now ?script? result. Get rid of the subst'ed script
* if it's hanging arond.
*/
@@ -581,7 +477,7 @@ TclCompileCatchCmd(
TclEmitOpcode(INST_POP, envPtr);
}
- /*
+ /*
* Result of all this, on either branch, should have been to leave
* one operand -- the return code -- on the stack.
*/
@@ -601,8 +497,8 @@ TclCompileCatchCmd(
* Procedure called to compile the "continue" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "continue" command at
@@ -644,8 +540,8 @@ TclCompileContinueCmd(
* Functions called to compile "dict" sucommands.
*
* Results:
- * All return TCL_OK for a successful compile, and TCL_ERROR to defer
- * evaluation to runtime.
+ * All return TCL_OK for a successful compile, and TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "dict" subcommand at
@@ -684,7 +580,6 @@ TclCompileDictSetCmd(
{
Tcl_Token *tokenPtr;
int numWords, i;
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int dictVarIndex, nameChars;
@@ -694,7 +589,7 @@ TclCompileDictSetCmd(
* There must be at least one argument after the command.
*/
- if (parsePtr->numWords < 4 || procPtr == NULL) {
+ if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
@@ -713,7 +608,10 @@ TclCompileDictSetCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Remaining words (key path and value to set) can be handled normally.
@@ -744,7 +642,6 @@ TclCompileDictIncrCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr;
int dictVarIndex, nameChars, incrAmount;
@@ -754,7 +651,7 @@ TclCompileDictIncrCmd(
* There must be at least two arguments after the command.
*/
- if (parsePtr->numWords < 3 || parsePtr->numWords > 4 || procPtr == NULL) {
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -802,7 +699,10 @@ TclCompileDictIncrCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Emit the key and the code to actually do the increment.
@@ -859,7 +759,6 @@ TclCompileDictForCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
@@ -875,7 +774,7 @@ TclCompileDictForCmd(
* There must be at least three argument after the command.
*/
- if (parsePtr->numWords != 4 || procPtr == NULL) {
+ if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
@@ -901,24 +800,28 @@ TclCompileDictForCmd(
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
nameChars = strlen(argv[0]);
if (!TclIsLocalScalar(argv[0], nameChars)) {
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
- keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr);
+ keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
nameChars = strlen(argv[1]);
if (!TclIsLocalScalar(argv[1], nameChars)) {
- ckfree((char *) argv);
+ ckfree(argv);
+ return TCL_ERROR;
+ }
+ valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
+ ckfree(argv);
+
+ if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
return TCL_ERROR;
}
- valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr);
- ckfree((char *) argv);
/*
* Allocate a temporary variable to store the iterator reference. The
@@ -927,7 +830,10 @@ TclCompileDictForCmd(
* (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (infoIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Preparation complete; issue instructions. Note that this code issues
@@ -972,7 +878,7 @@ TclCompileDictForCmd(
* Compile the loop body itself. It should be stack-neutral.
*/
- SetLineInformation (4);
+ SetLineInformation(4);
CompileBody(envPtr, bodyTokenPtr, interp);
TclEmitOpcode( INST_POP, envPtr);
@@ -1005,7 +911,8 @@ TclCompileDictForCmd(
*/
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP4, 0, envPtr);
@@ -1018,7 +925,8 @@ TclCompileDictForCmd(
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitOpcode( INST_RETURN_STK, envPtr);
@@ -1034,7 +942,8 @@ TclCompileDictForCmd(
envPtr->codeStart + emptyTargetOffset);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
@@ -1058,11 +967,11 @@ TclCompileDictUpdateCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
const char *name;
int i, nameChars, dictIndex, numVars, range, infoIndex;
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
@@ -1070,7 +979,7 @@ TclCompileDictUpdateCmd(
* There must be at least one argument after the command.
*/
- if (parsePtr->numWords < 5 || procPtr == NULL) {
+ if (parsePtr->numWords < 5) {
return TCL_ERROR;
}
@@ -1099,7 +1008,10 @@ TclCompileDictUpdateCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Assemble the instruction metadata. This is complex enough that it is
@@ -1107,10 +1019,9 @@ TclCompileDictUpdateCmd(
* that are to be used.
*/
- duiPtr = (DictUpdateInfo *)
- ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+ duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
duiPtr->length = numVars;
- keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp,
+ keyTokenPtrs = TclStackAlloc(interp,
sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
@@ -1127,16 +1038,12 @@ TclCompileDictUpdateCmd(
tokenPtr = TokenAfter(tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- ckfree((char *) duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
+ goto failedUpdateInfoAssembly;
}
name = tokenPtr[1].start;
nameChars = tokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- ckfree((char *) duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
+ goto failedUpdateInfoAssembly;
}
/*
@@ -1144,11 +1051,15 @@ TclCompileDictUpdateCmd(
*/
duiPtr->varIndices[i] =
- TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (duiPtr->varIndices[i] < 0) {
+ goto failedUpdateInfoAssembly;
+ }
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- ckfree((char *) duiPtr);
+ failedUpdateInfoAssembly:
+ ckfree(duiPtr);
TclStackFree(interp, keyTokenPtrs);
return TCL_ERROR;
}
@@ -1172,7 +1083,9 @@ TclCompileDictUpdateCmd(
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
+ envPtr->currStackDepth++;
CompileBody(envPtr, bodyTokenPtr, interp);
+ envPtr->currStackDepth = savedStackDepth;
ExceptionRangeEnds(envPtr, range);
/*
@@ -1224,7 +1137,6 @@ TclCompileDictAppendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
@@ -1235,7 +1147,7 @@ TclCompileDictAppendCmd(
* speed quite so much. ;-)
*/
- if (parsePtr->numWords<4 || parsePtr->numWords>100 || procPtr==NULL) {
+ if (parsePtr->numWords<4 || parsePtr->numWords>100) {
return TCL_ERROR;
}
@@ -1253,7 +1165,10 @@ TclCompileDictAppendCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
}
/*
@@ -1286,7 +1201,6 @@ TclCompileDictLappendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
int dictVarIndex, nameChars;
@@ -1296,7 +1210,7 @@ TclCompileDictLappendCmd(
* There must be three arguments after the command.
*/
- if (parsePtr->numWords != 4 || procPtr == NULL) {
+ if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
@@ -1311,7 +1225,10 @@ TclCompileDictLappendCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
@@ -1348,7 +1265,7 @@ DupDictUpdateInfo(
dui1Ptr = clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
- dui2Ptr = (DictUpdateInfo *) ckalloc(len);
+ dui2Ptr = ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
@@ -1381,13 +1298,58 @@ PrintDictUpdateInfo(
/*
*----------------------------------------------------------------------
*
+ * TclCompileErrorCmd --
+ *
+ * Procedure called to compile the "error" 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 "error" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileErrorCmd(
+ Tcl_Interp *interp, /* Used for context. */
+ 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: [error message ?errorInfo? ?errorCode?]
+ * However, we only deal with the case where there is just a message.
+ */
+ Tcl_Token *messageTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ PushLiteral(envPtr, "-code error -level 0", 20);
+ CompileWord(envPtr, messageTokenPtr, interp, 1);
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "expr" command at
@@ -1431,8 +1393,8 @@ TclCompileExprCmd(
* Procedure called to compile the "for" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "for" command at
@@ -1498,7 +1460,7 @@ TclCompileForCmd(
* Inline compile the initial command.
*/
- SetLineInformation (1);
+ SetLineInformation(1);
CompileBody(envPtr, startTokenPtr, interp);
TclEmitOpcode(INST_POP, envPtr);
@@ -1521,7 +1483,7 @@ TclCompileForCmd(
*/
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
- SetLineInformation (4);
+ SetLineInformation(4);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, bodyRange);
envPtr->currStackDepth = savedStackDepth + 1;
@@ -1533,7 +1495,7 @@ TclCompileForCmd(
envPtr->currStackDepth = savedStackDepth;
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
- SetLineInformation (3);
+ SetLineInformation(3);
CompileBody(envPtr, nextTokenPtr, interp);
ExceptionRangeEnds(envPtr, nextRange);
envPtr->currStackDepth = savedStackDepth + 1;
@@ -1554,7 +1516,7 @@ TclCompileForCmd(
testCodeOffset += 3;
}
- SetLineInformation (2);
+ SetLineInformation(2);
envPtr->currStackDepth = savedStackDepth;
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
@@ -1597,8 +1559,8 @@ TclCompileForCmd(
* Procedure called to compile the "foreach" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "foreach" command at
@@ -1675,7 +1637,7 @@ TclCompileForeachCmd(
*/
numLists = (numWords - 2)/2;
- varcList = (int *) TclStackAlloc(interp, numLists * sizeof(int));
+ varcList = TclStackAlloc(interp, numLists * sizeof(int));
memset(varcList, 0, numLists * sizeof(int));
varvList = (const char ***) TclStackAlloc(interp,
numLists * sizeof(const char **));
@@ -1753,13 +1715,13 @@ TclCompileForeachCmd(
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, procPtr);
+ /*create*/ 1, envPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, procPtr);
+ /*create*/ 1, envPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
@@ -1767,23 +1729,24 @@ TclCompileForeachCmd(
* pointing to the ForeachInfo structure.
*/
- infoPtr = (ForeachInfo *) ckalloc((unsigned)
- sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+ infoPtr = ckalloc(sizeof(ForeachInfo)
+ + numLists * sizeof(ForeachVarList *));
infoPtr->numLists = numLists;
infoPtr->firstValueTemp = firstValueTemp;
infoPtr->loopCtTemp = loopCtTemp;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
ForeachVarList *varListPtr;
+
numVars = varcList[loopIndex];
- varListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
+ varListPtr = ckalloc(sizeof(ForeachVarList)
+ + numVars * sizeof(int));
varListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
const char *varName = varvList[loopIndex][j];
int nameChars = strlen(varName);
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
- nameChars, /*create*/ 1, procPtr);
+ nameChars, /*create*/ 1, envPtr);
}
infoPtr->varLists[loopIndex] = varListPtr;
}
@@ -1804,7 +1767,7 @@ TclCompileForeachCmd(
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
- SetLineInformation (i);
+ SetLineInformation(i);
CompileTokens(envPtr, tokenPtr, interp);
tempVar = (firstValueTemp + loopIndex);
if (tempVar <= 255) {
@@ -1836,7 +1799,7 @@ TclCompileForeachCmd(
* Inline compile the loop body.
*/
- SetLineInformation (bodyIndex);
+ SetLineInformation(bodyIndex);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
@@ -1901,7 +1864,7 @@ TclCompileForeachCmd(
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != NULL) {
- ckfree((char *) varvList[loopIndex]);
+ ckfree(varvList[loopIndex]);
}
}
TclStackFree(interp, (void *)varvList);
@@ -1940,8 +1903,8 @@ DupForeachInfo(
register ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
- dupPtr = (ForeachInfo *) ckalloc((unsigned)
- sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+ dupPtr = ckalloc(sizeof(ForeachInfo)
+ + numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
@@ -1949,8 +1912,8 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
+ dupListPtr = ckalloc(sizeof(ForeachVarList)
+ + numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
@@ -1991,9 +1954,9 @@ FreeForeachInfo(
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
- ckfree((char *) listPtr);
+ ckfree(listPtr);
}
- ckfree((char *) infoPtr);
+ ckfree(infoPtr);
}
/*
@@ -2056,13 +2019,88 @@ PrintForeachInfo(
/*
*----------------------------------------------------------------------
*
+ * 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.
+ * 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
@@ -2081,7 +2119,7 @@ TclCompileIfCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
JumpFixupArray jumpFalseFixupArray;
- /* Used to fix the ifFalse jump after each
+ /* 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
@@ -2162,6 +2200,7 @@ TclCompileIfCmd(
Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
testTokenPtr[1].size);
+
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
TclDecrRefCount(boolObj);
@@ -2175,7 +2214,7 @@ TclCompileIfCmd(
compileScripts = 0;
}
} else {
- SetLineInformation (wordIdx);
+ SetLineInformation(wordIdx);
Tcl_ResetResult(interp);
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
@@ -2217,7 +2256,7 @@ TclCompileIfCmd(
*/
if (compileScripts) {
- SetLineInformation (wordIdx);
+ SetLineInformation(wordIdx);
envPtr->currStackDepth = savedStackDepth;
CompileBody(envPtr, tokenPtr, interp);
}
@@ -2305,7 +2344,7 @@ TclCompileIfCmd(
* Compile the else command body.
*/
- SetLineInformation (wordIdx);
+ SetLineInformation(wordIdx);
CompileBody(envPtr, tokenPtr, interp);
}
@@ -2378,8 +2417,8 @@ TclCompileIfCmd(
* Procedure called to compile the "incr" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2407,8 +2446,8 @@ TclCompileIncrCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
+ 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
@@ -2424,6 +2463,7 @@ TclCompileIncrCmd(
int numBytes = incrTokenPtr[1].size;
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
+
Tcl_IncrRefCount(intObj);
code = TclGetIntFromObj(NULL, intObj, &immValue);
TclDecrRefCount(intObj);
@@ -2434,7 +2474,7 @@ TclCompileIncrCmd(
PushLiteral(envPtr, word, numBytes);
}
} else {
- SetLineInformation (2);
+ SetLineInformation(2);
CompileTokens(envPtr, incrTokenPtr, interp);
}
} else { /* No incr amount given so use 1. */
@@ -2491,13 +2531,85 @@ TclCompileIncrCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileInfoExistsCmd --
+ *
+ * Procedure called to compile the "info exists" subcommand.
+ *
+ * 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 exists"
+ * subcommand at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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) {
+ 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);
+ }
+ }
+ } else {
+ TclEmitOpcode(INST_EXIST_STK, 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.
+ * 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
@@ -2549,8 +2661,8 @@ TclCompileLappendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
* If we are doing an assignment, push the new value. In the no values
@@ -2559,6 +2671,7 @@ TclCompileLappendCmd(
if (numWords > 2) {
Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
+
CompileWord(envPtr, valueTokenPtr, interp, 2);
}
@@ -2604,8 +2717,8 @@ TclCompileLappendCmd(
* Procedure called to compile the "lassign" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2655,8 +2768,8 @@ TclCompileLassignCmd(
* Generate the next variable name.
*/
- PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
- &simpleVarName, &isScalar, idx+2);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
+ &simpleVarName, &isScalar, idx+2);
/*
* Emit instructions to get the idx'th item out of the list value on
@@ -2719,8 +2832,8 @@ TclCompileLassignCmd(
* Procedure called to compile the "lindex" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2802,7 +2915,7 @@ TclCompileLindexCmd(
if (numWords == 3) {
TclEmitOpcode(INST_LIST_INDEX, envPtr);
} else {
- TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
}
return TCL_OK;
@@ -2816,8 +2929,8 @@ TclCompileLindexCmd(
* Procedure called to compile the "list" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2880,8 +2993,8 @@ TclCompileListCmd(
* Procedure called to compile the "llength" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2920,8 +3033,8 @@ TclCompileLlengthCmd(
* Procedure called to compile the "lset" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -2992,8 +3105,8 @@ TclCompileLsetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
* Push the "index" args and the new element value.
@@ -3094,13 +3207,96 @@ TclCompileLsetCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileNamespaceCmd --
+ *
+ * Procedure called to compile the "namespace" command; currently, only
+ * the subcommand "namespace upvar" is compiled to bytecodes, and then
+ * 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
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileRegexpCmd --
*
* Procedure called to compile the "regexp" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -3121,7 +3317,7 @@ TclCompileRegexpCmd(
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
int i, len, nocase, exact, sawLast, simple;
- char *str;
+ const char *str;
DefineLineInformation; /* TIP #280 */
/*
@@ -3155,7 +3351,7 @@ TclCompileRegexpCmd(
return TCL_ERROR;
}
- str = (char *) varTokenPtr[1].start;
+ str = varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sawLast++;
@@ -3191,8 +3387,9 @@ TclCompileRegexpCmd(
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
Tcl_DString ds;
- str = (char *) varTokenPtr[1].start;
+ str = varTokenPtr[1].start;
len = varTokenPtr[1].size;
+
/*
* If it has a '-', it could be an incorrectly formed regexp command.
*/
@@ -3246,7 +3443,9 @@ TclCompileRegexpCmd(
* 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);
}
@@ -3261,8 +3460,8 @@ TclCompileRegexpCmd(
* Procedure called to compile the "return" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -3317,8 +3516,7 @@ TclCompileReturnCmd(
* Allocate some working space.
*/
- objv = (Tcl_Obj **) TclStackAlloc(interp,
- numOptionWords * sizeof(Tcl_Obj *));
+ objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
/*
* Scan through the return options. If any are unknown at compile time,
@@ -3385,6 +3583,7 @@ TclCompileReturnCmd(
while (index >= 0) {
ExceptionRange range = envPtr->exceptArrayPtr[index];
+
if ((range.type == CATCH_EXCEPTION_RANGE)
&& (range.catchOffset == -1)) {
enclosingCatch = 1;
@@ -3442,6 +3641,7 @@ TclCompileSyntaxError(
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,
Tcl_GetReturnOptions(interp, TCL_ERROR));
@@ -3450,23 +3650,23 @@ TclCompileSyntaxError(
/*
*----------------------------------------------------------------------
*
- * TclCompileSetCmd --
+ * TclCompileUpvarCmd --
*
- * Procedure called to compile the "set" command.
+ * Procedure called to compile the "upvar" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
+ * Instructions are added to envPtr to execute the "upvar" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileSetCmd(
+TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -3474,405 +3674,108 @@ TclCompileSetCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *varTokenPtr, *valueTokenPtr;
- int isAssignment, isScalar, simpleVarName, localIndex, numWords;
+ 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 != 2) && (numWords != 3)) {
+ if (numWords < 3) {
+ Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
- isAssignment = (numWords == 3);
/*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
+ * Push the frame index if it is known at compile time
*/
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If we are doing an assignment, push the new value.
- */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ CallFrame *framePtr;
+ const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
- if (isAssignment) {
- valueTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
+ /*
+ * Attempt to convert to a level reference. Note that TclObjGetFrame
+ * only changes the obj type when a conversion was successful.
+ */
- /*
- * Emit instructions to set/get the variable.
- */
+ TclObjGetFrame(interp, objPtr, &framePtr);
+ newTypePtr = objPtr->typePtr;
+ Tcl_DecrRefCount(objPtr);
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1((isAssignment?
- INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
- localIndex, envPtr);
- } else {
- TclEmitInstInt4((isAssignment?
- INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
- localIndex, envPtr);
+ if (newTypePtr != typePtr) {
+ if (numWords%2) {
+ return TCL_ERROR;
}
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ otherTokenPtr = TokenAfter(tokenPtr);
+ i = 4;
} else {
- if (localIndex < 0) {
- TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1((isAssignment?
- INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
- localIndex, envPtr);
- } else {
- TclEmitInstInt4((isAssignment?
- INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
- localIndex, envPtr);
+ if (!(numWords%2)) {
+ return TCL_ERROR;
}
+ PushLiteral(envPtr, "1", 1);
+ otherTokenPtr = tokenPtr;
+ i = 3;
}
} else {
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringCmpCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string compare" 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 "string compare"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringCmpCmd(
- 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;
-
- /*
- * We don't support any flags; the bytecode isn't that sophisticated.
- */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
-
- /*
- * Push the two operands onto the stack and then the test.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(INST_STR_CMP, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringEqualCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string equal" 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 "string equal" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringEqualCmd(
- 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;
-
- /*
- * We don't support any flags; the bytecode isn't that sophisticated.
- */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
-
- /*
- * Push the two operands onto the stack and then the test.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringIndexCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string index" 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 "string index" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringIndexCmd(
- 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 != 3) {
+ Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
/*
- * Push the two operands onto the stack and then the index operation.
+ * 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.
*/
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(INST_STR_INDEX, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringMatchCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string match" 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 "string match" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringMatchCmd(
- 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;
- int i, length, exactMatch = 0, nocase = 0;
- const char *str;
-
- if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Check if we have a -nocase flag.
- */
+ for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
+ localTokenPtr = TokenAfter(otherTokenPtr);
- if (parsePtr->numWords == 4) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- str = tokenPtr[1].start;
- length = tokenPtr[1].size;
- if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
- /*
- * Fail at run time, not in compilation.
- */
+ CompileWord(envPtr, otherTokenPtr, interp, 1);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
}
- nocase = 1;
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- /*
- * Push the strings to match against each other.
- */
-
- for (i = 0; i < 2; i++) {
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- str = tokenPtr[1].start;
- length = tokenPtr[1].size;
- if (!nocase && (i == 0)) {
- /*
- * Trivial matches can be done by 'string equal'. If -nocase
- * was specified, we can't do this because INST_STR_EQ has no
- * support for nocase.
- */
-
- Tcl_Obj *copy = Tcl_NewStringObj(str, length);
-
- Tcl_IncrRefCount(copy);
- exactMatch = TclMatchIsTrivial(TclGetString(copy));
- TclDecrRefCount(copy);
- }
- PushLiteral(envPtr, str, length);
- } else {
- SetLineInformation (i+1+nocase);
- CompileTokens(envPtr, tokenPtr, interp);
- }
- tokenPtr = TokenAfter(tokenPtr);
+ TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
}
/*
- * Push the matcher.
+ * Pop the frame index, and set the result to empty
*/
- if (exactMatch) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringLenCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string length" 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 "string length"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringLenCmd(
- 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 TCL_ERROR;
- }
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Here someone is asking for the length of a static string. Just push
- * the actual character (not byte) length.
- */
-
- char buf[TCL_INTEGER_SPACE];
- int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);
-
- len = sprintf(buf, "%d", len);
- PushLiteral(envPtr, buf, len);
- } else {
- SetLineInformation (1);
- CompileTokens(envPtr, tokenPtr, interp);
- TclEmitOpcode(INST_STR_LEN, envPtr);
- }
+ TclEmitOpcode(INST_POP, envPtr);
+ PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileSwitchCmd --
+ * TclCompileVariableCmd --
*
- * Procedure called to compile the "switch" command.
+ * Procedure called to compile the "variable" command.
*
* Results:
- * Returns TCL_OK for successful compile, or TCL_ERROR to defer
- * evaluation to runtime (either when it is too complex to get the
- * semantics right, or when we know for sure that it is an error but need
- * the error to happen at the right time).
+ * 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 "switch" command at
+ * Instructions are added to envPtr to execute the "variable" command at
* runtime.
*
- * FIXME:
- * Stack depths are probably not calculated correctly.
- *
*----------------------------------------------------------------------
*/
int
-TclCompileSwitchCmd(
+TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -3880,1036 +3783,158 @@ TclCompileSwitchCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
- int numWords; /* Number of words in command. */
-
- Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
- enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
- /* What kind of switch are we doing? */
-
- Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
- Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
- int *bodyLines; /* Array of line numbers for body list
- * items. */
- int** bodyNext;
- int foundDefault; /* Flag to indicate whether a "default" clause
- * is present. */
-
- JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
- int *fixupTargetArray; /* Array of places for fixups to point at. */
- int fixupCount; /* Number of places to fix up. */
- int contFixIndex; /* Where the first of the jumps due to a group
- * of continuation bodies starts, or -1 if
- * there aren't any. */
- int contFixCount; /* Number of continuation bodies pointing to
- * the current (or next) real body. */
-
- int savedStackDepth = envPtr->currStackDepth;
- int noCase; /* Has the -nocase flag been given? */
- int foundMode = 0; /* Have we seen a mode flag yet? */
- int isListedArms = 0;
- int i, valueIndex;
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
- int* clNext = envPtr->clNext;
-
- /*
- * Only handle the following versions:
- * switch ?--? word {pattern body ...}
- * switch -exact ?--? word {pattern body ...}
- * switch -glob ?--? word {pattern body ...}
- * switch -regexp ?--? word {pattern body ...}
- * switch -- word simpleWordPattern simpleWordBody ...
- * switch -exact -- word simpleWordPattern simpleWordBody ...
- * switch -glob -- word simpleWordPattern simpleWordBody ...
- * switch -regexp -- word simpleWordPattern simpleWordBody ...
- * When the mode is -glob, can also handle a -nocase flag.
- *
- * First off, we don't care how the command's word was generated; we're
- * compiling it anyway! So skip it...
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- valueIndex = 1;
- numWords = parsePtr->numWords-1;
-
- /*
- * Check for options.
- */
- noCase = 0;
- mode = Switch_Exact;
- if (numWords == 2) {
- /*
- * There's just the switch value and the bodies list. In that case, we
- * can skip all option parsing and move on to consider switch values
- * and the body list.
- */
-
- goto finishedOptionParse;
+ numWords = parsePtr->numWords;
+ if (numWords < 2) {
+ return TCL_ERROR;
}
/*
- * There must be at least one option, --, because without that there is no
- * way to statically avoid the problems you get from strings-to-be-matched
- * that start with a - (the interpreted code falls apart if it encounters
- * them, so we punt if we *might* encounter them as that is the easiest
- * way of emulating the behaviour).
+ * Bail out if not compiling a proc body
*/
- for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
- register unsigned size = tokenPtr[1].size;
- register const char *chrs = tokenPtr[1].start;
-
- /*
- * We only process literal options, and we assume that -e, -g and -n
- * are unique prefixes of -exact, -glob and -nocase respectively (true
- * at time of writing). Note that -exact and -glob may only be given
- * at most once or we bail out (error case).
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
- return TCL_ERROR;
- }
-
- if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Exact;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Glob;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Regexp;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
- noCase = 1;
- valueIndex++;
- continue;
- } else if ((size == 2) && !memcmp(chrs, "--", 2)) {
- valueIndex++;
- break;
- }
-
- /*
- * The switch command has many flags we cannot compile at all (e.g.
- * all the RE-related ones) which we must have encountered. Either
- * that or we have run off the end. The action here is the same: punt
- * to interpreted version.
- */
-
- return TCL_ERROR;
- }
- if (numWords < 3) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- numWords--;
- if (noCase && (mode == Switch_Exact)) {
- /*
- * Can't compile this case; no opcode for case-insensitive equality!
- */
-
+ if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/*
- * The value to test against is going to always get pushed on the stack.
- * But not yet; we need to verify that the rest of the command is
- * compilable too.
- */
-
- finishedOptionParse:
- valueTokenPtr = tokenPtr;
- /* For valueIndex, see previous loop. */
- tokenPtr = TokenAfter(tokenPtr);
- numWords--;
-
- /*
- * Build an array of tokens for the matcher terms and script bodies. Note
- * that in the case of the quoted bodies, this is tricky as we cannot use
- * copies of the string from the input token for the generated tokens (it
- * causes a crash during exception handling). When multiple tokens are
- * available at this point, this is pretty easy.
+ * Loop over the (var, value) pairs.
*/
- if (numWords == 1) {
- Tcl_DString bodyList;
- const char **argv = NULL, *tokenStartPtr, *p;
- int bline; /* TIP #280: line of the pattern/action list,
- * and start of list for when tracking the
- * location. This list comes immediately after
- * the value we switch on. */
- int isTokenBraced;
-
- /*
- * Test that we've got a suitable body list as a simple (i.e. braced)
- * word, and that the elements of the body are simple words too. This
- * is really rather nasty indeed.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
-
- Tcl_DStringInit(&bodyList);
- Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
- if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords,
- &argv) != TCL_OK) {
- Tcl_DStringFree(&bodyList);
- return TCL_ERROR;
- }
- Tcl_DStringFree(&bodyList);
-
- /*
- * Now we know what the switch arms are, we've got to see whether we
- * can synthesize tokens for the arms. First check whether we've got a
- * valid number of arms since we can do that now.
- */
-
- if (numWords == 0 || numWords % 2) {
- ckfree((char *) argv);
- return TCL_ERROR;
- }
-
- isListedArms = 1;
- bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
- bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = (int *) ckalloc(sizeof(int) * numWords);
- bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
-
- /*
- * Locate the start of the arms within the overall word.
- */
-
- bline = mapPtr->loc[eclIndex].line[valueIndex+1];
- p = tokenStartPtr = tokenPtr[1].start;
- while (isspace(UCHAR(*tokenStartPtr))) {
- tokenStartPtr++;
- }
- if (*tokenStartPtr == '{') {
- tokenStartPtr++;
- isTokenBraced = 1;
- } else {
- isTokenBraced = 0;
- }
-
- /*
- * TIP #280: Count lines within the literal list.
- */
-
- for (i=0 ; i<numWords ; i++) {
- bodyTokenArray[i].type = TCL_TOKEN_TEXT;
- bodyTokenArray[i].start = tokenStartPtr;
- bodyTokenArray[i].size = strlen(argv[i]);
- bodyTokenArray[i].numComponents = 0;
- bodyToken[i] = bodyTokenArray+i;
- tokenStartPtr += bodyTokenArray[i].size;
-
- /*
- * Test to see if we have guessed the end of the word correctly;
- * if not, we can't feed the real string to the sub-compilation
- * engine, and we're then stuck and so have to punt out to doing
- * everything at runtime.
- */
-
- if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
- (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
- && !isspace(UCHAR(*tokenStartPtr)))) {
- ckfree((char *) argv);
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- return TCL_ERROR;
- }
-
- /*
- * TIP #280: Now determine the line the list element starts on
- * (there is no need to do it earlier, due to the possibility of
- * aborting, see above).
- */
-
- TclAdvanceLines(&bline, p, bodyTokenArray[i].start);
- TclAdvanceContinuations (&bline, &clNext,
- bodyTokenArray[i].start - envPtr->source);
- bodyLines[i] = bline;
- bodyNext[i] = clNext;
- p = bodyTokenArray[i].start;
-
- while (isspace(UCHAR(*tokenStartPtr))) {
- tokenStartPtr++;
- if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
- break;
- }
- }
- if (*tokenStartPtr == '{') {
- tokenStartPtr++;
- isTokenBraced = 1;
- } else {
- isTokenBraced = 0;
- }
- }
- ckfree((char *) argv);
+ valueTokenPtr = parsePtr->tokenPtr;
+ for (i=2; i<=numWords; i+=2) {
+ varTokenPtr = TokenAfter(valueTokenPtr);
+ valueTokenPtr = TokenAfter(varTokenPtr);
- /*
- * Check that we've parsed everything we thought we were going to
- * parse. If not, something odd is going on (I believe it is possible
- * to defeat the code above) and we should bail out.
- */
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
- if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
+ if (localIndex < 0) {
return TCL_ERROR;
}
- } else if (numWords % 2 || numWords == 0) {
- /*
- * Odd number of words (>1) available, or no words at all available.
- * Both are error cases, so punt and let the interpreted-version
- * generate the error message. Note that the second case probably
- * should get caught earlier, but it's easy to check here again anyway
- * because it'd cause a nasty crash otherwise.
- */
-
- return TCL_ERROR;
- } else {
- /*
- * Multi-word definition of patterns & actions.
- */
-
- bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = (int *) ckalloc(sizeof(int) * numWords);
- bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
- bodyTokenArray = NULL;
- for (i=0 ; i<numWords ; i++) {
- /*
- * We only handle the very simplest case. Anything more complex is
- * a good reason to go to the interpreted case anyway due to
- * traces, etc.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
- tokenPtr->numComponents != 1) {
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- return TCL_ERROR;
- }
- bodyToken[i] = tokenPtr+1;
-
- /*
- * TIP #280: Copy line information from regular cmd info.
- */
-
- bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
- bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
- tokenPtr = TokenAfter(tokenPtr);
- }
- }
-
- /*
- * Fall back to interpreted if the last body is a continuation (it's
- * illegal, but this makes the error happen at the right time).
- */
-
- if (bodyToken[numWords-1]->size == 1 &&
- bodyToken[numWords-1]->start[0] == '-') {
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
- return TCL_ERROR;
- }
-
- /*
- * Now we commit to generating code; the parsing stage per se is done.
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation (valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
- * Check if we can generate a jump table, since if so that's faster than
- * doing an explicit compare with each body. Note that we're definitely
- * over-conservative with determining whether we can do the jump table,
- * but it handles the most common case well enough.
- */
-
- if (isListedArms && mode == Switch_Exact && !noCase) {
- JumptableInfo *jtPtr;
- int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
- int mustGenerate, jumpToDefault;
- Tcl_DString buffer;
- Tcl_HashEntry *hPtr;
-
- /*
- * 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 table itself is independent of any invokation of the
- * bytecode, and as such is stored in an auxData block.
- *
- * Start by allocating the jump table itself, plus some workspace.
- */
-
- jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
- Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
- infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
- finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2));
- foundDefault = 0;
- mustGenerate = 1;
-
- /*
- * Next, issue the instruction to do the jump, together with what we
- * want to do if things do not work out (jump to either the default
- * clause or the "default" default, which just sets the result to
- * empty). Note that we will come back and rewrite the jump's offset
- * parameter when we know what it should be, and that all jumps we
- * issue are of the wide kind because that makes the code much easier
- * to debug!
- */
-
- jumpLocation = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
- jumpToDefault = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
- for (i=0 ; i<numWords ; i+=2) {
+ if (i != numWords) {
/*
- * For each arm, we must first work out what to do with the match
- * term.
+ * A value has been given: set the variable, pop the value
*/
- if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
- memcmp(bodyToken[numWords-2]->start, "default", 7)) {
- /*
- * This is not a default clause, so insert the current
- * location as a target in the jump table (assuming it isn't
- * already there, which would indicate that this clause is
- * probably masked by an earlier one). Note that we use a
- * Tcl_DString here simply because the hash API does not let
- * us specify the string length.
- */
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, bodyToken[i]->start,
- bodyToken[i]->size);
- hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
- Tcl_DStringValue(&buffer), &isNew);
- if (isNew) {
- /*
- * First time we've encountered this match clause, so it
- * must point to here.
- */
-
- Tcl_SetHashValue(hPtr, (ClientData)
- (CurrentOffset(envPtr) - jumpLocation));
- }
- Tcl_DStringFree(&buffer);
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ if (localIndex < 0x100) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
} else {
- /*
- * This is a default clause, so patch up the fallthrough from
- * the INST_JUMP_TABLE instruction to here.
- */
-
- foundDefault = 1;
- isNew = 1;
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
- envPtr->codeStart+jumpToDefault+1);
- }
-
- /*
- * Now, for each arm we must deal with the body of the clause.
- *
- * If this is a continuation body (never true of a final clause,
- * whether default or not) we're done because the next jump target
- * will also point here, so we advance to the next clause.
- */
-
- if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
- mustGenerate = 1;
- continue;
- }
-
- /*
- * Also skip this arm if its only match clause is masked. (We
- * could probably be more aggressive about this, but that would be
- * much more difficult to get right.)
- */
-
- if (!isNew && !mustGenerate) {
- continue;
+ TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
- mustGenerate = 0;
-
- /*
- * Compile the body of the arm.
- */
-
- envPtr->line = bodyLines[i+1]; /* TIP #280 */
- envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
- TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
-
- /*
- * Compile a jump in to the end of the command if this body is
- * anything other than a user-supplied default arm (to either skip
- * over the remaining bodies or the code that generates an empty
- * result).
- */
-
- if (i+2 < numWords || !foundDefault) {
- finalFixups[numRealBodies++] = CurrentOffset(envPtr);
-
- /*
- * Easier by far to issue this jump as a fixed-width jump.
- * Otherwise we'd need to do a lot more (and more awkward)
- * rewriting when we fixed this all up.
- */
-
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
- }
- }
-
- /*
- * We're at the end. If we've not already done so through the
- * processing of a user-supplied default clause, add in a "default"
- * default clause now.
- */
-
- if (!foundDefault) {
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
- envPtr->codeStart+jumpToDefault+1);
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * No more instructions to be issued; everything that needs to jump to
- * the end of the command is fixed up at this point.
- */
-
- for (i=0 ; i<numRealBodies ; i++) {
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
- envPtr->codeStart+finalFixups[i]+1);
- }
-
- /*
- * Clean up all our temporary space and return.
- */
-
- ckfree((char *) finalFixups);
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
- return TCL_OK;
- }
-
- /*
- * Generate a test for each arm.
- */
-
- contFixIndex = -1;
- contFixCount = 0;
- fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
- fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
- memset(fixupTargetArray, 0, numWords * sizeof(int));
- fixupCount = 0;
- foundDefault = 0;
- for (i=0 ; i<numWords ; i+=2) {
- int nextArmFixupIndex = -1;
-
- envPtr->currStackDepth = savedStackDepth + 1;
- if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
- memcmp(bodyToken[numWords-2]->start, "default", 7)) {
- /*
- * Generate the test for the arm.
- */
-
- switch (mode) {
- case Switch_Exact:
- TclEmitOpcode(INST_DUP, envPtr);
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- break;
- case Switch_Glob:
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
- break;
- case Switch_Regexp: {
- int simple = 0, exact = 0;
-
- /*
- * Keep in sync with TclCompileRegexpCmd.
- */
-
- if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
- Tcl_DString ds;
-
- if (bodyToken[i]->size == 0) {
- /*
- * The semantics of regexps are that they always match
- * when the RE == "".
- */
-
- PushLiteral(envPtr, "1", 1);
- break;
- }
-
- /*
- * Attempt to convert pattern to glob. If successful, push
- * the converted pattern.
- */
-
- if (TclReToGlob(NULL, bodyToken[i]->start,
- bodyToken[i]->size, &ds, &exact) == TCL_OK) {
- simple = 1;
- PushLiteral(envPtr, Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
- if (!simple) {
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- }
-
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- 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
- * or capture vars.
- */
-
- int cflags = TCL_REG_ADVANCED
- | (noCase ? TCL_REG_NOCASE : 0);
-
- TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
- }
- break;
- }
- default:
- Tcl_Panic("unknown switch mode: %d", mode);
- }
-
- /*
- * In a fall-through case, we will jump on _true_ to the place
- * where the body starts (generated later, with guarantee of this
- * ensured earlier; the final body is never a fall-through).
- */
-
- if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
- if (contFixIndex == -1) {
- contFixIndex = fixupCount;
- contFixCount = 0;
- }
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
- fixupArray+contFixIndex+contFixCount);
- fixupCount++;
- contFixCount++;
- continue;
- }
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount);
- nextArmFixupIndex = fixupCount;
- fixupCount++;
- } else {
- /*
- * Got a default clause; set a flag to inhibit the generation of
- * the jump after the body and the cleanup of the intermediate
- * value that we are switching against.
- *
- * Note that default clauses (which are always terminal clauses)
- * cannot be fall-through clauses as well, since the last clause
- * is never a fall-through clause (which we have already
- * verified).
- */
-
- foundDefault = 1;
- }
-
- /*
- * Generate the body for the arm. This is guaranteed not to be a
- * fall-through case, but it might have preceding fall-through cases,
- * so we must process those first.
- */
-
- if (contFixIndex != -1) {
- int j;
-
- for (j=0 ; j<contFixCount ; j++) {
- fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
- }
- contFixIndex = -1;
- }
-
- /*
- * Now do the actual compilation. Note that we do not use CompileBody
- * because we may have synthesized the tokens in a non-standard
- * pattern.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->line = bodyLines[i+1]; /* TIP #280 */
- envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
- TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
-
- if (!foundDefault) {
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- fixupArray+fixupCount);
- fixupCount++;
- fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
- }
- }
-
- /*
- * Clean up all our temporary space and return.
- */
-
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
-
- /*
- * Discard the value we are matching against unless we've had a default
- * clause (in which case it will already be gone due to the code at the
- * start of processing an arm, guaranteed) and make the result of the
- * command an empty string.
- */
-
- if (!foundDefault) {
- TclEmitOpcode(INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * Do jump fixups for arms that were executed. First, fill in the jumps of
- * all jumps that don't point elsewhere to point to here.
- */
-
- for (i=0 ; i<fixupCount ; i++) {
- if (fixupTargetArray[i] == 0) {
- fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
+ TclEmitOpcode(INST_POP, envPtr);
}
}
/*
- * Now scan backwards over all the jumps (all of which are forward jumps)
- * doing each one. When we do one and there is a size changes, we must
- * scan back over all the previous ones and see if they need adjusting
- * before proceeding with further jump fixups (the interleaved nature of
- * all the jumps makes this impossible to do without nested loops).
+ * Set the result to empty
*/
- for (i=fixupCount-1 ; i>=0 ; i--) {
- if (TclFixupForwardJump(envPtr, &fixupArray[i],
- fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
- int j;
-
- for (j=i-1 ; j>=0 ; j--) {
- if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
- fixupTargetArray[j] += 3;
- }
- }
- }
- }
- ckfree((char *) fixupArray);
- ckfree((char *) fixupTargetArray);
-
- envPtr->currStackDepth = savedStackDepth + 1;
+ PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * DupJumptableInfo, FreeJumptableInfo --
- *
- * Functions to duplicate, release and print a jump-table created for use
- * with the INST_JUMP_TABLE instruction.
- *
- * Results:
- * DupJumptableInfo: a copy of the jump-table
- * FreeJumptableInfo: none
- * PrintJumptableInfo: none
- *
- * Side effects:
- * DupJumptableInfo: allocates memory
- * FreeJumptableInfo: releases memory
- * PrintJumptableInfo: none
- *
- *----------------------------------------------------------------------
- */
-
-static ClientData
-DupJumptableInfo(
- ClientData clientData)
-{
- JumptableInfo *jtPtr = clientData;
- JumptableInfo *newJtPtr = (JumptableInfo *)
- ckalloc(sizeof(JumptableInfo));
- Tcl_HashEntry *hPtr, *newHPtr;
- Tcl_HashSearch search;
- int isNew;
-
- Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
- hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
- while (hPtr != NULL) {
- newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
- Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
- Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
- }
- return newJtPtr;
-}
-
-static void
-FreeJumptableInfo(
- ClientData clientData)
-{
- JumptableInfo *jtPtr = clientData;
-
- Tcl_DeleteHashTable(&jtPtr->hashTable);
- ckfree((char *) jtPtr);
-}
-
-static void
-PrintJumptableInfo(
- ClientData clientData,
- Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
-{
- register JumptableInfo *jtPtr = clientData;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch search;
- const char *keyPtr;
- int offset, i = 0;
-
- hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
- for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
- offset = PTR2INT(Tcl_GetHashValue(hPtr));
-
- if (i++) {
- Tcl_AppendToObj(appendObj, ", ", -1);
- if (i%4==0) {
- Tcl_AppendToObj(appendObj, "\n\t\t", -1);
- }
- }
- Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
- keyPtr, pcOffset + offset);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileWhileCmd --
+ * IndexTailVarIfKnown --
*
- * Procedure called to compile the "while" command.
+ * 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 TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * Returns the variable's index in the table of compiled locals if the
+ * tail is known at compile time, or -1 otherwise.
*
* Side effects:
- * Instructions are added to envPtr to execute the "while" command at
- * runtime.
+ * None.
*
*----------------------------------------------------------------------
*/
-int
-TclCompileWhileCmd(
- 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. */
+static int
+IndexTailVarIfKnown(
+ Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- 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;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
+ Tcl_Obj *tailPtr;
+ const char *tailName, *p;
+ int len, n = varTokenPtr->numComponents;
+ Tcl_Token *lastTokenPtr;
+ int full, localIndex;
/*
- * If the test expression requires substitutions, don't compile the while
- * command inline. E.g., the expression might cause the loop to never
- * execute or execute forever, as in "while "$x < 5" {}".
+ * 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.
*
- * Bail out also if the body expression requires substitutions in order to
- * insure correct behaviour [Bug 219166]
+ * 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.
*/
- testTokenPtr = TokenAfter(parsePtr->tokenPtr);
- bodyTokenPtr = TokenAfter(testTokenPtr);
-
- if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
- || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
- return TCL_ERROR;
+ if (!EnvHasLVT(envPtr)) {
+ return -1;
}
- /*
- * Find out if the condition is a constant.
- */
+ 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;
+ }
+ }
- boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
- Tcl_IncrRefCount(boolObj);
- code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
- if (code == TCL_OK) {
- if (boolVal) {
- /*
- * It is an infinite loop; flag it so that we generate a more
- * efficient body.
- */
+ tailName = TclGetStringFromObj(tailPtr, &len);
- loopMayEnd = 0;
- } else {
+ if (len) {
+ if (*(tailName+len-1) == ')') {
/*
- * This is an empty loop: "while 0 {...}" or such. Compile no
- * bytecodes.
+ * Possible array: bail out
*/
- goto pushResult;
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
}
- }
-
- /*
- * Create a ExceptionRange record for the loop body. This is used to
- * implement break and continue.
- */
-
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
-
- /*
- * Jump to the evaluation of the condition. This code uses the "loop
- * rotation" optimisation (which eliminates one branch from the loop).
- * "while cond body" produces then:
- * goto A
- * B: body : bodyCodeOffset
- * A: cond -> result : testCodeOffset, continueOffset
- * if (result) goto B
- *
- * The infinite loop "while 1 body" produces:
- * B: body : all three offsets here
- * goto B
- */
- if (loopMayEnd) {
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
- testCodeOffset = 0; /* Avoid compiler warning. */
- } else {
/*
- * Make sure that the first command in the body is preceded by an
- * INST_START_CMD, and hence counted properly. [Bug 1752146]
+ * Get the tail: immediately after the last '::'
*/
- envPtr->atCmdStart = 0;
- testCodeOffset = CurrentOffset(envPtr);
- }
-
- /*
- * Compile the loop body.
- */
-
- SetLineInformation (2);
- bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
- ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Compile the test expression then emit the conditional jump that
- * terminates the while. We already know it's a simple word.
- */
-
- if (loopMayEnd) {
- testCodeOffset = CurrentOffset(envPtr);
- jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
- bodyCodeOffset += 3;
- testCodeOffset += 3;
+ for (p = tailName + len -1; p > tailName; p--) {
+ if ((*p == ':') && (*(p-1) == ':')) {
+ p++;
+ break;
+ }
}
- envPtr->currStackDepth = savedStackDepth;
- SetLineInformation (1);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
+ if (!full && (p == tailName)) {
+ /*
+ * No :: in the last component.
+ */
- jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
- if (jumpDist > 127) {
- TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
- }
- } else {
- jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
- if (jumpDist > 127) {
- TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
}
+ len -= p - tailName;
+ tailName = p;
}
- /*
- * Set the loop's body, continue and break offsets.
- */
-
- envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
- envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
- ExceptionRangeTarget(envPtr, range, breakOffset);
-
- /*
- * The while command's result is an empty string.
- */
-
- pushResult:
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
+ localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return localIndex;
}
/*
@@ -4921,8 +3946,8 @@ TclCompileWhileCmd(
* necessary (append, lappend, set).
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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
@@ -4936,12 +3961,13 @@ PushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
+ 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 */
+ 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;
@@ -5002,8 +4028,7 @@ PushVarName(
* assemble the corresponding token.
*/
- elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
- sizeof(Tcl_Token));
+ elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -5016,7 +4041,6 @@ PushVarName(
&& (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.
*/
@@ -5039,9 +4063,9 @@ PushVarName(
*/
if (varTokenPtr[n].size == 1) {
- --n;
+ n--;
} else {
- --varTokenPtr[n].size;
+ varTokenPtr[n].size--;
removedParen = n;
}
@@ -5049,7 +4073,7 @@ PushVarName(
nameChars = p - varTokenPtr[1].start;
elName = p + 1;
remainingChars = (varTokenPtr[2].start - p) - 1;
- elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
+ elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2;
if (remainingChars) {
/*
@@ -5057,8 +4081,7 @@ PushVarName(
* token.
*/
- elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
- n * sizeof(Tcl_Token));
+ elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -5089,6 +4112,7 @@ PushVarName(
*/
int hasNsQualifiers = 0;
+
for (i = 0, p = name; i < nameChars; i++, p++) {
if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
hasNsQualifiers = 1;
@@ -5102,10 +4126,9 @@ PushVarName(
* push its name and look it up at runtime.
*/
- if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
+ if (!hasNsQualifiers) {
localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ flags & TCL_CREATE_VAR,
- envPtr->procPtr);
+ 1, envPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
@@ -5126,7 +4149,8 @@ PushVarName(
if (elNameChars) {
envPtr->line = line;
envPtr->clNext = clNext;
- TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
+ TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
+ envPtr);
} else {
PushLiteral(envPtr, "", 0);
}
@@ -5142,7 +4166,7 @@ PushVarName(
}
if (removedParen) {
- ++varTokenPtr[removedParen].size;
+ varTokenPtr[removedParen].size++;
}
if (allocedTokens) {
TclStackFree(interp, elemTokenPtr);
@@ -5154,1389 +4178,6 @@ PushVarName(
}
/*
- *----------------------------------------------------------------------
- *
- * CompileUnaryOpCmd --
- *
- * Utility routine to compile the unary operator commands.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileUnaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode(instruction, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileAssociativeBinaryOpCmd --
- *
- * Utility routine to compile the binary operator commands that accept an
- * arbitrary number of arguments, and that are associative operations.
- * Because of the associativity, we may combine operations from right to
- * left, saving us any effort of re-ordering the arguments on the stack
- * after substitutions are completed.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileAssociativeBinaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- const char *identity,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, identity, -1);
- words++;
- }
- if (words > 3) {
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- }
- while (--words > 1) {
- TclEmitOpcode(instruction, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileStrictlyBinaryOpCmd --
- *
- * Utility routine to compile the binary operator commands, that strictly
- * accept exactly two arguments.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileStrictlyBinaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
- return CompileAssociativeBinaryOpCmd(interp, parsePtr,
- NULL, instruction, envPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileComparisonOpCmd --
- *
- * Utility routine to compile the n-ary comparison operator commands.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileComparisonOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(instruction, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(instruction, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- }
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- if (++words < parsePtr->numWords) {
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- }
- TclEmitOpcode(instruction, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
-
- /*
- * Drop the value from the temp variable; retaining that reference
- * might be expensive elsewhere.
- */
-
- PushLiteral(envPtr, "", 0);
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompile*OpCmd --
- *
- * Procedures called to compile the corresponding "::tcl::mathop::*"
- * commands. These are all wrappers around the utility operator command
- * compiler functions, except for the compilers for subtraction and
- * division, which are special.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileInvertOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
-}
-
-int
-TclCompileNotOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
-}
-
-int
-TclCompileAddOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
- envPtr);
-}
-
-int
-TclCompileMulOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
- envPtr);
-}
-
-int
-TclCompileAndOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
- envPtr);
-}
-
-int
-TclCompileOrOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
- envPtr);
-}
-
-int
-TclCompileXorOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
- envPtr);
-}
-
-int
-TclCompilePowOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- /*
- * This one has its own implementation because the ** operator is
- * the only one with right associativity.
- */
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, "1", 1);
- words++;
- }
- while (--words > 1) {
- TclEmitOpcode(INST_EXPON, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileLshiftOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
-}
-
-int
-TclCompileRshiftOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
-}
-
-int
-TclCompileModOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
-}
-
-int
-TclCompileNeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
-}
-
-int
-TclCompileStrneqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
-}
-
-int
-TclCompileInOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
-}
-
-int
-TclCompileNiOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
- envPtr);
-}
-
-int
-TclCompileLessOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
-}
-
-int
-TclCompileLeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
-}
-
-int
-TclCompileGreaterOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
-}
-
-int
-TclCompileGeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
-}
-
-int
-TclCompileEqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
-}
-
-int
-TclCompileStreqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
-}
-
-int
-TclCompileMinusOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- if (parsePtr->numWords == 1) {
- /* Fallback to direct eval to report syntax error */
- return TCL_ERROR;
- }
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (words == 2) {
- TclEmitOpcode(INST_UMINUS, envPtr);
- return TCL_OK;
- }
- if (words == 3) {
- TclEmitOpcode(INST_SUB, envPtr);
- return TCL_OK;
- }
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- while (--words > 1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_SUB, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileDivOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- if (parsePtr->numWords == 1) {
- /* Fallback to direct eval to report syntax error */
- return TCL_ERROR;
- }
- if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "1.0", 3);
- }
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (words <= 3) {
- TclEmitOpcode(INST_DIV, envPtr);
- return TCL_OK;
- }
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- while (--words > 1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_DIV, 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 (envPtr->procPtr == NULL) {
- 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,
- /*create*/ TCL_CREATE_VAR,
- envPtr->procPtr);
- Tcl_DecrRefCount(tailPtr);
- return localIndex;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- 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, TCL_CREATE_VAR,
- &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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileNamespaceCmd --
- *
- * Procedure called to compile the "namespace" command; currently, only
- * the subcommand "namespace upvar" is compiled to bytecodes.
- *
- * 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
-TclCompileNamespaceCmd(
- 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 odd number of args, >=5
- */
-
- numWords = parsePtr->numWords;
- if (!(numWords%2) || (numWords < 5)) {
- return TCL_ERROR;
- }
-
- /*
- * Check if the second argument is "upvar"
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */
- || strncmp(tokenPtr->start, "upvar", 5)) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- tokenPtr = TokenAfter(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=4; i<=numWords; i+=2) {
- otherTokenPtr = TokenAfter(localTokenPtr);
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, TCL_CREATE_VAR,
- &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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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=2; 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, 1);
- TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
-
- if (i != numWords) {
- /*
- * A value has been given: set the variable, pop the value
- */
-
- CompileWord(envPtr, valueTokenPtr, interp, 1);
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
- }
- }
-
- /*
- * Set the result to empty
- */
-
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileEnsemble --
- *
- * Procedure called to compile an ensemble command. Note that most
- * ensembles are not compiled, since modifying a compiled ensemble causes
- * a invalidation of all existing bytecode (expensive!) which is not
- * normally warranted.
- *
- * 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 subcommands of the
- * ensemble at runtime if a compile-time mapping is possible.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileEnsemble(
- 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;
- Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
- Tcl_Command ensemble = (Tcl_Command) cmdPtr;
- Tcl_Parse synthetic;
- int len, numBytes, result, flags = 0, i;
- const char *word;
-
- if (parsePtr->numWords < 2) {
- return TCL_ERROR;
- }
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Too hard.
- */
-
- return TCL_ERROR;
- }
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
-
- /*
- * There's a sporting chance we'll be able to compile this. But now we
- * must check properly. To do that, check that we're compiling an ensemble
- * that has a compilable command as its appropriate subcommand.
- */
-
- if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
- || mapObj == NULL) {
- /*
- * Either not an ensemble or a mapping isn't installed. Crud. Too hard
- * to proceed.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Next, get the flags. We need them on several code paths.
- */
-
- (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
-
- /*
- * Check to see if there's also a subcommand list; must check to see if
- * the subcommand we are calling is in that list if it exists, since that
- * list filters the entries in the map.
- */
-
- (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
- if (listObj != NULL) {
- int sclen;
- const char *str;
- Tcl_Obj *matchObj = NULL;
-
- if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
- }
- for (i=0 ; i<len ; i++) {
- str = Tcl_GetStringFromObj(elems[i], &sclen);
- if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) {
- /*
- * Exact match! Excellent!
- */
-
- result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
- if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
- }
- goto doneMapLookup;
- }
-
- /*
- * Check to see if we've got a prefix match. A single prefix match
- * is fine, and allows us to refine our dictionary lookup, but
- * multiple prefix matches is a Bad Thing and will prevent us from
- * making progress. Note that we cannot do the lookup immediately
- * in the prefix case; might be another entry later in the list
- * that causes things to fail.
- */
-
- if ((flags & TCL_ENSEMBLE_PREFIX)
- && strncmp(word, str, (unsigned) numBytes) == 0) {
- if (matchObj != NULL) {
- return TCL_ERROR;
- }
- matchObj = elems[i];
- }
- }
- if (matchObj != NULL) {
- result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
- if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
- }
- goto doneMapLookup;
- }
- return TCL_ERROR;
- } else {
- /*
- * No map, so check the dictionary directly.
- */
-
- TclNewStringObj(subcmdObj, word, numBytes);
- result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
- TclDecrRefCount(subcmdObj);
- if (result == TCL_OK && targetCmdObj != NULL) {
- /*
- * Got it. Skip the fiddling around with prefixes.
- */
-
- goto doneMapLookup;
- }
-
- /*
- * We've not literally got a valid subcommand. But maybe we have a
- * prefix. Check if prefix matches are allowed.
- */
-
- if (flags & TCL_ENSEMBLE_PREFIX) {
- Tcl_DictSearch s;
- int done, matched;
- Tcl_Obj *tmpObj;
-
- /*
- * Iterate over the keys in the dictionary, checking to see if
- * we're a prefix.
- */
-
- Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done);
- matched = 0;
- while (!done) {
- if (strncmp(TclGetString(subcmdObj), word,
- (unsigned) numBytes) == 0) {
- if (matched++) {
- /*
- * Must have matched twice! Not unique, so no point
- * looking further.
- */
-
- break;
- }
- targetCmdObj = tmpObj;
- }
- Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
- }
- Tcl_DictObjDone(&s);
-
- /*
- * If we have anything other than a single match, we've failed the
- * unique prefix check.
- */
-
- if (matched != 1) {
- return TCL_ERROR;
- }
- } else {
- return TCL_ERROR;
- }
- }
-
- /*
- * OK, we definitely map to something. But what?
- *
- * The command we map to is the first word out of the map element. Note
- * that we also reject dealing with multi-element rewrites if we are in a
- * safe interpreter, as there is otherwise a (highly gnarly!) way to make
- * Tcl crash open to exploit.
- */
-
- doneMapLookup:
- if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
- }
- if (len > 1 && Tcl_IsSafe(interp)) {
- return TCL_ERROR;
- }
- targetCmdObj = elems[0];
-
- Tcl_IncrRefCount(targetCmdObj);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
- TclDecrRefCount(targetCmdObj);
- if (cmdPtr == NULL || cmdPtr->compileProc == NULL) {
- /*
- * Maps to an undefined command or a command without a compiler.
- * Cannot compile.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Now we've done the mapping process, can now actually try to compile.
- * We do this by handing off to the subcommand's actual compiler. But to
- * do that, we have to perform some trickery to rewrite the arguments.
- */
-
- TclParseInit(interp, NULL, 0, &synthetic);
- synthetic.numWords = parsePtr->numWords - 2 + len;
- TclGrowParseTokenArray(&synthetic, 2*len);
- synthetic.numTokens = 2*len;
-
- /*
- * Now we have the space to work in, install something rewritten. Note
- * that we are here praying for all our might that none of these words are
- * a script; the error detection code will crash if that happens and there
- * is nothing we can do to avoid it!
- */
-
- for (i=0 ; i<len ; i++) {
- int sclen;
- const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
-
- synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
- synthetic.tokenPtr[2*i].start = str;
- synthetic.tokenPtr[2*i].size = sclen;
- synthetic.tokenPtr[2*i].numComponents = 1;
-
- synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
- synthetic.tokenPtr[2*i+1].start = str;
- synthetic.tokenPtr[2*i+1].size = sclen;
- synthetic.tokenPtr[2*i+1].numComponents = 0;
- }
-
- /*
- * Copy over the real argument tokens.
- */
-
- for (i=len; i<synthetic.numWords; i++) {
- int toCopy;
- tokenPtr = TokenAfter(tokenPtr);
- toCopy = tokenPtr->numComponents + 1;
- TclGrowParseTokenArray(&synthetic, toCopy);
- memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
- sizeof(Tcl_Token) * toCopy);
- synthetic.numTokens += toCopy;
- }
-
- /*
- * Hand off compilation to the subcommand compiler. At last!
- */
-
- result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
-
- /*
- * Clean up if necessary.
- */
-
- Tcl_FreeParse(&synthetic);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileInfoExistsCmd --
- *
- * Procedure called to compile the "info exists" subcommand.
- *
- * 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 exists"
- * subcommand at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-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, TCL_CREATE_VAR, &localIndex,
- &simpleVarName, &isScalar, 1);
-
- /*
- * Emit instruction to check the variable for existence.
- */
-
- if (simpleVarName) {
- 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);
- }
- }
- } else {
- TclEmitOpcode(INST_EXIST_STK, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
new file mode 100644
index 0000000..d956819
--- /dev/null
+++ b/generic/tclCompCmdsSZ.c
@@ -0,0 +1,3644 @@
+/*
+ * tclCompCmdsSZ.c --
+ *
+ * This file contains compilation procedures that compile various Tcl
+ * commands (beginning with the letters 's' through 'z', except for
+ * [upvar] and [variable]) into a sequence of instructions ("bytecodes").
+ * Also includes the operator command compilers.
+ *
+ * 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-2010 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"
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static ClientData DupJumptableInfo(ClientData clientData);
+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);
+static int CompileComparisonOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int instruction,
+ CompileEnv *envPtr);
+static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int instruction,
+ CompileEnv *envPtr);
+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,
+ Tcl_Token **bodyToken, int *bodyLines,
+ int **bodyContLines);
+static int IssueTryFinallyInstructions(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,
+ 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 */
+
+/*
+ * The structures below define the AuxData types defined in this file.
+ */
+
+const AuxDataType tclJumptableInfoType = {
+ "JumptableInfo", /* name */
+ DupJumptableInfo, /* dupProc */
+ FreeJumptableInfo, /* freeProc */
+ PrintJumptableInfo /* printProc */
+};
+
+/*
+ * Shorthand macros for instruction issuing.
+ */
+
+#define OP(name) TclEmitOpcode(INST_##name, envPtr)
+#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
+#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),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) \
+ TclStoreInt4AtPtr(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));}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSetCmd --
+ *
+ * Procedure called to compile the "set" 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 "set" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSetCmd(
+ 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 isAssignment, isScalar, simpleVarName, localIndex, numWords;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords;
+ if ((numWords != 2) && (numWords != 3)) {
+ return TCL_ERROR;
+ }
+ isAssignment = (numWords == 3);
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+
+ /*
+ * If we are doing an assignment, push the new value.
+ */
+
+ if (isAssignment) {
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
+ }
+
+ /*
+ * 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);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1((isAssignment?
+ INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstInt4((isAssignment?
+ INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
+ localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode((isAssignment?
+ INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1((isAssignment?
+ INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstInt4((isAssignment?
+ INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
+ localIndex, envPtr);
+ }
+ }
+ } else {
+ TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringCmpCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string compare" 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 "string compare"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringCmpCmd(
+ 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;
+
+ /*
+ * We don't support any flags; the bytecode isn't that sophisticated.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the test.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(INST_STR_CMP, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringEqualCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string equal" 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 "string equal" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringEqualCmd(
+ 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;
+
+ /*
+ * We don't support any flags; the bytecode isn't that sophisticated.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the test.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringIndexCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string index" 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 "string index" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringIndexCmd(
+ 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 != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the index operation.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(INST_STR_INDEX, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringMatchCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string match" 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 "string match" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringMatchCmd(
+ 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;
+ int i, length, exactMatch = 0, nocase = 0;
+ const char *str;
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Check if we have a -nocase flag.
+ */
+
+ if (parsePtr->numWords == 4) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ str = tokenPtr[1].start;
+ length = tokenPtr[1].size;
+ if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
+ /*
+ * Fail at run time, not in compilation.
+ */
+
+ return TCL_ERROR;
+ }
+ nocase = 1;
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Push the strings to match against each other.
+ */
+
+ for (i = 0; i < 2; i++) {
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ str = tokenPtr[1].start;
+ length = tokenPtr[1].size;
+ if (!nocase && (i == 0)) {
+ /*
+ * Trivial matches can be done by 'string equal'. If -nocase
+ * was specified, we can't do this because INST_STR_EQ has no
+ * support for nocase.
+ */
+
+ Tcl_Obj *copy = Tcl_NewStringObj(str, length);
+
+ Tcl_IncrRefCount(copy);
+ exactMatch = TclMatchIsTrivial(TclGetString(copy));
+ TclDecrRefCount(copy);
+ }
+ PushLiteral(envPtr, str, length);
+ } else {
+ SetLineInformation(i+1+nocase);
+ CompileTokens(envPtr, tokenPtr, interp);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Push the matcher.
+ */
+
+ if (exactMatch) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringLenCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string length" 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 "string length"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringLenCmd(
+ 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;
+ Tcl_Obj *objPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ TclNewObj(objPtr);
+ if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ /*
+ * Here someone is asking for the length of a static string (or
+ * something with backslashes). Just push the actual character (not
+ * byte) length.
+ */
+
+ char buf[TCL_INTEGER_SPACE];
+ int len = Tcl_GetCharLength(objPtr);
+
+ len = sprintf(buf, "%d", len);
+ PushLiteral(envPtr, buf, len);
+ } else {
+ SetLineInformation(1);
+ CompileTokens(envPtr, tokenPtr, interp);
+ TclEmitOpcode(INST_STR_LEN, envPtr);
+ }
+ TclDecrRefCount(objPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSubstCmd --
+ *
+ * Procedure called to compile the "subst" command.
+ *
+ * Results:
+ * Returns TCL_OK for successful compile, or TCL_ERROR to defer
+ * evaluation to runtime (either when it is too complex to get the
+ * semantics right, or when we know for sure that it is an error but need
+ * the error to happen at the right time).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "subst" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSubstCmd(
+ 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. */
+{
+ int numArgs = parsePtr->numWords - 1;
+ int numOpts = numArgs - 1;
+ int objc, flags = TCL_SUBST_ALL;
+ Tcl_Obj **objv/*, *toSubst = NULL*/;
+ Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ int code = TCL_ERROR;
+ DefineLineInformation; /* TIP #280 */
+
+ if (numArgs == 0) {
+ return TCL_ERROR;
+ }
+
+ objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
+
+ for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
+ objv[objc] = Tcl_NewObj();
+ Tcl_IncrRefCount(objv[objc]);
+ if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
+ objc++;
+ goto cleanup;
+ }
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+
+/*
+ if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) {
+ toSubst = objv[numOpts];
+ Tcl_IncrRefCount(toSubst);
+ }
+*/
+
+ /* TODO: Figure out expansion to cover WordKnownAtCompileTime
+ * The difficulty is that WKACT makes a copy, and if TclSubstParse
+ * below parses the copy of the original source string, some deep
+ * parts of the compile machinery get upset. They want all pointers
+ * stored in Tcl_Tokens to point back to the same original string.
+ */
+ if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ code = TclSubstOptions(NULL, numOpts, objv, &flags);
+ }
+
+ cleanup:
+ while (--objc >= 0) {
+ TclDecrRefCount(objv[objc]);
+ }
+ TclStackFree(interp, objv);
+ if (/*toSubst == NULL*/ code != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ SetLineInformation(numArgs);
+ TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size,
+ flags, mapPtr->loc[eclIndex].line[numArgs], envPtr);
+
+/* TclDecrRefCount(toSubst);*/
+ return TCL_OK;
+}
+
+void
+TclSubstCompile(
+ Tcl_Interp *interp,
+ const char *bytes,
+ int numBytes,
+ int flags,
+ int line,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *endTokenPtr, *tokenPtr;
+ int breakOffset = 0, count = 0, bline = line;
+ Tcl_Parse parse;
+ Tcl_InterpState state = NULL;
+
+ TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
+
+ /*
+ * 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
+ * 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);
+ count++;
+ }
+
+ for (endTokenPtr = tokenPtr + parse.numTokens;
+ tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
+ int length, literal, catchRange, breakJump;
+ char buf[TCL_UTF_MAX];
+ JumpFixup startFixup, okFixup, returnFixup, breakFixup;
+ JumpFixup continueFixup, otherFixup, endFixup;
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ literal = TclRegisterNewLiteral(envPtr,
+ tokenPtr->start, tokenPtr->size);
+ TclEmitPush(literal, envPtr);
+ TclAdvanceLines(&bline, tokenPtr->start,
+ tokenPtr->start + tokenPtr->size);
+ count++;
+ continue;
+ case TCL_TOKEN_BS:
+ length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
+ NULL, buf);
+ literal = TclRegisterNewLiteral(envPtr, buf, length);
+ TclEmitPush(literal, envPtr);
+ count++;
+ continue;
+ }
+
+ while (count > 255) {
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ count -= 254;
+ }
+ if (count > 1) {
+ TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ count = 1;
+ }
+
+ if (breakOffset == 0) {
+ /* Jump to the start (jump over the jump to end) */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup);
+
+ /* Jump to the end (all BREAKs land here) */
+ breakOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+
+ /* Start */
+ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d",
+ (int) (CurrentOffset(envPtr) - startFixup.codeOffset));
+ }
+ }
+
+ envPtr->line = bline;
+ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr);
+ ExceptionRangeStarts(envPtr, catchRange);
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_COMMAND:
+ TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2,
+ envPtr);
+ count++;
+ break;
+ case TCL_TOKEN_VARIABLE:
+ TclCompileVarSubst(interp, tokenPtr, envPtr);
+ count++;
+ break;
+ default:
+ Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d",
+ tokenPtr->type);
+ }
+
+ ExceptionRangeEnds(envPtr, catchRange);
+
+ /* Substitution produced TCL_OK */
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
+
+ /* Exceptional return codes processed here */
+ ExceptionRangeTarget(envPtr, catchRange, catchOffset);
+ TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode(INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+ TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr);
+
+ /* ERROR -> reraise it */
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ TclEmitOpcode(INST_NOP, envPtr);
+
+ /* RETURN */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
+
+ /* BREAK */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup);
+
+ /* CONTINUE */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup);
+
+ /* OTHER */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
+
+ /* BREAK destination */
+ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
+ (int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+
+ breakJump = CurrentOffset(envPtr) - breakOffset;
+ if (breakJump > 127) {
+ TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr);
+ }
+
+ /* CONTINUE destination */
+ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
+ (int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
+
+ /* RETURN + other destination */
+ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
+ (int) (CurrentOffset(envPtr) - returnFixup.codeOffset));
+ }
+ if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
+ (int) (CurrentOffset(envPtr) - otherFixup.codeOffset));
+ }
+
+ /*
+ * Pull the result to top of stack, discard options dict.
+ */
+
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * 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) {
+ TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ count = 1;
+ }
+
+ /* CONTINUE jump to here */
+ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) {
+ Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
+ (int) (CurrentOffset(envPtr) - endFixup.codeOffset));
+ }
+ bline = envPtr->line;
+ }
+
+
+ while (count > 255) {
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ count -= 254;
+ }
+ if (count > 1) {
+ TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ }
+
+ Tcl_FreeParse(&parse);
+
+ if (state != NULL) {
+ Tcl_RestoreInterpState(interp, state);
+ TclCompileSyntaxError(interp, envPtr);
+ }
+
+ /* Final target of the multi-jump from all BREAKs */
+ if (breakOffset > 0) {
+ TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset,
+ envPtr->codeStart + breakOffset);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSwitchCmd --
+ *
+ * Procedure called to compile the "switch" command.
+ *
+ * Results:
+ * Returns TCL_OK for successful compile, or TCL_ERROR to defer
+ * evaluation to runtime (either when it is too complex to get the
+ * semantics right, or when we know for sure that it is an error but need
+ * the error to happen at the right time).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "switch" command at
+ * runtime.
+ *
+ * FIXME:
+ * Stack depths are probably not calculated correctly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSwitchCmd(
+ 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; /* Pointer to tokens in command. */
+ int numWords; /* Number of words in command. */
+ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
+ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
+ /* What kind of switch are we doing? */
+ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
+ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
+ int *bodyLines; /* Array of line numbers for body list
+ * items. */
+ int **bodyContLines; /* Array of continuation line info. */
+ int noCase; /* Has the -nocase flag been given? */
+ int foundMode = 0; /* Have we seen a mode flag yet? */
+ int isListedArms = 0;
+ int i, valueIndex;
+ int result = TCL_ERROR;
+ DefineLineInformation; /* TIP #280 */
+ int *clNext = envPtr->clNext;
+
+ /*
+ * Only handle the following versions:
+ * switch ?--? word {pattern body ...}
+ * switch -exact ?--? word {pattern body ...}
+ * switch -glob ?--? word {pattern body ...}
+ * switch -regexp ?--? word {pattern body ...}
+ * switch -- word simpleWordPattern simpleWordBody ...
+ * switch -exact -- word simpleWordPattern simpleWordBody ...
+ * switch -glob -- word simpleWordPattern simpleWordBody ...
+ * switch -regexp -- word simpleWordPattern simpleWordBody ...
+ * When the mode is -glob, can also handle a -nocase flag.
+ *
+ * First off, we don't care how the command's word was generated; we're
+ * compiling it anyway! So skip it...
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ valueIndex = 1;
+ numWords = parsePtr->numWords-1;
+
+ /*
+ * Check for options.
+ */
+
+ noCase = 0;
+ mode = Switch_Exact;
+ if (numWords == 2) {
+ /*
+ * There's just the switch value and the bodies list. In that case, we
+ * can skip all option parsing and move on to consider switch values
+ * and the body list.
+ */
+
+ goto finishedOptionParse;
+ }
+
+ /*
+ * There must be at least one option, --, because without that there is no
+ * way to statically avoid the problems you get from strings-to-be-matched
+ * that start with a - (the interpreted code falls apart if it encounters
+ * them, so we punt if we *might* encounter them as that is the easiest
+ * way of emulating the behaviour).
+ */
+
+ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
+ register unsigned size = tokenPtr[1].size;
+ register const char *chrs = tokenPtr[1].start;
+
+ /*
+ * We only process literal options, and we assume that -e, -g and -n
+ * are unique prefixes of -exact, -glob and -nocase respectively (true
+ * at time of writing). Note that -exact and -glob may only be given
+ * at most once or we bail out (error case).
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
+ return TCL_ERROR;
+ }
+
+ if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Exact;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Glob;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Regexp;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
+ noCase = 1;
+ valueIndex++;
+ continue;
+ } else if ((size == 2) && !memcmp(chrs, "--", 2)) {
+ valueIndex++;
+ break;
+ }
+
+ /*
+ * The switch command has many flags we cannot compile at all (e.g.
+ * all the RE-related ones) which we must have encountered. Either
+ * that or we have run off the end. The action here is the same: punt
+ * to interpreted version.
+ */
+
+ return TCL_ERROR;
+ }
+ if (numWords < 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ numWords--;
+ if (noCase && (mode == Switch_Exact)) {
+ /*
+ * Can't compile this case; no opcode for case-insensitive equality!
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * The value to test against is going to always get pushed on the stack.
+ * But not yet; we need to verify that the rest of the command is
+ * compilable too.
+ */
+
+ finishedOptionParse:
+ valueTokenPtr = tokenPtr;
+ /* For valueIndex, see previous loop. */
+ tokenPtr = TokenAfter(tokenPtr);
+ numWords--;
+
+ /*
+ * Build an array of tokens for the matcher terms and script bodies. Note
+ * that in the case of the quoted bodies, this is tricky as we cannot use
+ * copies of the string from the input token for the generated tokens (it
+ * causes a crash during exception handling). When multiple tokens are
+ * available at this point, this is pretty easy.
+ */
+
+ if (numWords == 1) {
+ Tcl_DString bodyList;
+ const char **argv = NULL, *tokenStartPtr, *p;
+ int bline; /* TIP #280: line of the pattern/action list,
+ * and start of list for when tracking the
+ * location. This list comes immediately after
+ * the value we switch on. */
+ int isTokenBraced;
+
+ /*
+ * Test that we've got a suitable body list as a simple (i.e. braced)
+ * word, and that the elements of the body are simple words too. This
+ * is really rather nasty indeed.
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ Tcl_DStringInit(&bodyList);
+ Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
+ if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords,
+ &argv) != TCL_OK) {
+ Tcl_DStringFree(&bodyList);
+ return TCL_ERROR;
+ }
+ Tcl_DStringFree(&bodyList);
+
+ /*
+ * Now we know what the switch arms are, we've got to see whether we
+ * can synthesize tokens for the arms. First check whether we've got a
+ * valid number of arms since we can do that now.
+ */
+
+ if (numWords == 0 || numWords % 2) {
+ ckfree(argv);
+ return TCL_ERROR;
+ }
+
+ isListedArms = 1;
+ bodyTokenArray = ckalloc(sizeof(Tcl_Token) * numWords);
+ bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
+ bodyLines = ckalloc(sizeof(int) * numWords);
+ bodyContLines = ckalloc(sizeof(int*) * numWords);
+
+ /*
+ * Locate the start of the arms within the overall word.
+ */
+
+ bline = mapPtr->loc[eclIndex].line[valueIndex+1];
+ p = tokenStartPtr = tokenPtr[1].start;
+ while (isspace(UCHAR(*tokenStartPtr))) {
+ tokenStartPtr++;
+ }
+ if (*tokenStartPtr == '{') {
+ tokenStartPtr++;
+ isTokenBraced = 1;
+ } else {
+ isTokenBraced = 0;
+ }
+
+ /*
+ * TIP #280: Count lines within the literal list.
+ */
+
+ for (i=0 ; i<numWords ; i++) {
+ bodyTokenArray[i].type = TCL_TOKEN_TEXT;
+ bodyTokenArray[i].start = tokenStartPtr;
+ bodyTokenArray[i].size = strlen(argv[i]);
+ bodyTokenArray[i].numComponents = 0;
+ bodyToken[i] = bodyTokenArray+i;
+ tokenStartPtr += bodyTokenArray[i].size;
+
+ /*
+ * Test to see if we have guessed the end of the word correctly;
+ * if not, we can't feed the real string to the sub-compilation
+ * engine, and we're then stuck and so have to punt out to doing
+ * everything at runtime.
+ */
+
+ if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
+ (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
+ && !isspace(UCHAR(*tokenStartPtr)))) {
+ ckfree(argv);
+ goto freeTemporaries;
+ }
+
+ /*
+ * TIP #280: Now determine the line the list element starts on
+ * (there is no need to do it earlier, due to the possibility of
+ * aborting, see above).
+ */
+
+ TclAdvanceLines(&bline, p, bodyTokenArray[i].start);
+ TclAdvanceContinuations(&bline, &clNext,
+ bodyTokenArray[i].start - envPtr->source);
+ bodyLines[i] = bline;
+ bodyContLines[i] = clNext;
+ p = bodyTokenArray[i].start;
+
+ while (isspace(UCHAR(*tokenStartPtr))) {
+ tokenStartPtr++;
+ if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
+ break;
+ }
+ }
+ if (*tokenStartPtr == '{') {
+ tokenStartPtr++;
+ isTokenBraced = 1;
+ } else {
+ isTokenBraced = 0;
+ }
+ }
+ ckfree(argv);
+
+ /*
+ * Check that we've parsed everything we thought we were going to
+ * parse. If not, something odd is going on (I believe it is possible
+ * to defeat the code above) and we should bail out.
+ */
+
+ if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
+ goto freeTemporaries;
+ }
+
+ } else if (numWords % 2 || numWords == 0) {
+ /*
+ * Odd number of words (>1) available, or no words at all available.
+ * Both are error cases, so punt and let the interpreted-version
+ * generate the error message. Note that the second case probably
+ * should get caught earlier, but it's easy to check here again anyway
+ * because it'd cause a nasty crash otherwise.
+ */
+
+ return TCL_ERROR;
+ } else {
+ /*
+ * Multi-word definition of patterns & actions.
+ */
+
+ bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
+ bodyLines = ckalloc(sizeof(int) * numWords);
+ bodyContLines = ckalloc(sizeof(int*) * numWords);
+ bodyTokenArray = NULL;
+ for (i=0 ; i<numWords ; i++) {
+ /*
+ * We only handle the very simplest case. Anything more complex is
+ * a good reason to go to the interpreted case anyway due to
+ * traces, etc.
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
+ tokenPtr->numComponents != 1) {
+ goto freeTemporaries;
+ }
+ bodyToken[i] = tokenPtr+1;
+
+ /*
+ * TIP #280: Copy line information from regular cmd info.
+ */
+
+ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
+ bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ }
+
+ /*
+ * Fall back to interpreted if the last body is a continuation (it's
+ * illegal, but this makes the error happen at the right time).
+ */
+
+ if (bodyToken[numWords-1]->size == 1 &&
+ bodyToken[numWords-1]->start[0] == '-') {
+ goto freeTemporaries;
+ }
+
+ /*
+ * Now we commit to generating code; the parsing stage per se is done.
+ * Check if we can generate a jump table, since if so that's faster than
+ * doing an explicit compare with each body. Note that we're definitely
+ * over-conservative with determining whether we can do the jump table,
+ * but it handles the most common case well enough.
+ */
+
+ if ((isListedArms) && (mode == Switch_Exact) && (!noCase)) {
+ IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex,
+ valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines);
+ } else {
+ IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase,
+ valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines,
+ bodyContLines);
+ }
+ result = TCL_OK;
+
+ /*
+ * Clean up all our temporary space and return.
+ */
+
+ freeTemporaries:
+ ckfree(bodyToken);
+ ckfree(bodyLines);
+ ckfree(bodyContLines);
+ if (bodyTokenArray != NULL) {
+ ckfree(bodyTokenArray);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IssueSwitchChainedTests --
+ *
+ * Generate instructions for a [switch] command that is to be compiled
+ * into a sequence of tests. This is the generic handle-everything mode
+ * that inherently has performance that is (on average) linear in the
+ * number of tests. It is the only mode that can handle -glob and -regexp
+ * matches, or anything that is case-insensitive. It does not handle the
+ * wild-and-wooly end of regexp matching (i.e., capture of match results)
+ * so that's when we spill to the interpreted version.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
+ int *bodyLines, /* Array of line numbers for body list
+ * items. */
+ 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. */
+ int *fixupTargetArray; /* Array of places for fixups to point at. */
+ int fixupCount; /* Number of places to fix up. */
+ int contFixIndex; /* Where the first of the jumps due to a group
+ * of continuation bodies starts, or -1 if
+ * there aren't any. */
+ int contFixCount; /* Number of continuation bodies pointing to
+ * the current (or next) real body. */
+ int nextArmFixupIndex;
+ int simple, exact; /* For extracting the type of regexp. */
+ 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.
+ */
+
+ contFixIndex = -1;
+ contFixCount = 0;
+ fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
+ fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
+ memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
+ fixupCount = 0;
+ 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)) {
+ /*
+ * Generate the test for the arm.
+ */
+
+ switch (mode) {
+ case Switch_Exact:
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ break;
+ case Switch_Glob:
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
+ break;
+ case Switch_Regexp:
+ simple = exact = 0;
+
+ /*
+ * Keep in sync with TclCompileRegexpCmd.
+ */
+
+ if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
+ Tcl_DString ds;
+
+ if (bodyToken[i]->size == 0) {
+ /*
+ * The semantics of regexps are that they always match
+ * when the RE == "".
+ */
+
+ PushLiteral(envPtr, "1", 1);
+ break;
+ }
+
+ /*
+ * Attempt to convert pattern to glob. If successful, push
+ * the converted pattern.
+ */
+
+ if (TclReToGlob(NULL, bodyToken[i]->start,
+ bodyToken[i]->size, &ds, &exact) == TCL_OK) {
+ simple = 1;
+ PushLiteral(envPtr, Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+ if (!simple) {
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ }
+
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ if (!simple) {
+ /*
+ * 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
+ * or capture vars.
+ */
+
+ int cflags = TCL_REG_ADVANCED
+ | (noCase ? TCL_REG_NOCASE : 0);
+
+ TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
+ } else if (exact && !noCase) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
+ }
+ break;
+ default:
+ Tcl_Panic("unknown switch mode: %d", mode);
+ }
+
+ /*
+ * In a fall-through case, we will jump on _true_ to the place
+ * where the body starts (generated later, with guarantee of this
+ * ensured earlier; the final body is never a fall-through).
+ */
+
+ if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
+ if (contFixIndex == -1) {
+ contFixIndex = fixupCount;
+ contFixCount = 0;
+ }
+ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
+ &fixupArray[contFixIndex+contFixCount]);
+ fixupCount++;
+ contFixCount++;
+ continue;
+ }
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ &fixupArray[fixupCount]);
+ nextArmFixupIndex = fixupCount;
+ fixupCount++;
+ } else {
+ /*
+ * Got a default clause; set a flag to inhibit the generation of
+ * the jump after the body and the cleanup of the intermediate
+ * value that we are switching against.
+ *
+ * Note that default clauses (which are always terminal clauses)
+ * cannot be fall-through clauses as well, since the last clause
+ * is never a fall-through clause (which we have already
+ * verified).
+ */
+
+ foundDefault = 1;
+ }
+
+ /*
+ * Generate the body for the arm. This is guaranteed not to be a
+ * fall-through case, but it might have preceding fall-through cases,
+ * so we must process those first.
+ */
+
+ if (contFixIndex != -1) {
+ int j;
+
+ for (j=0 ; j<contFixCount ; j++) {
+ fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
+ }
+ contFixIndex = -1;
+ }
+
+ /*
+ * Now do the actual compilation. Note that we do not use CompileBody
+ * because we may have synthesized the tokens in a non-standard
+ * pattern.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+ 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);
+
+ if (!foundDefault) {
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &fixupArray[fixupCount]);
+ fixupCount++;
+ fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
+ }
+ }
+
+ /*
+ * Discard the value we are matching against unless we've had a default
+ * clause (in which case it will already be gone due to the code at the
+ * start of processing an arm, guaranteed) and make the result of the
+ * command an empty string.
+ */
+
+ if (!foundDefault) {
+ TclEmitOpcode(INST_POP, envPtr);
+ PushLiteral(envPtr, "", 0);
+ }
+
+ /*
+ * Do jump fixups for arms that were executed. First, fill in the jumps of
+ * all jumps that don't point elsewhere to point to here.
+ */
+
+ for (i=0 ; i<fixupCount ; i++) {
+ if (fixupTargetArray[i] == 0) {
+ fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
+ }
+ }
+
+ /*
+ * Now scan backwards over all the jumps (all of which are forward jumps)
+ * doing each one. When we do one and there is a size changes, we must
+ * scan back over all the previous ones and see if they need adjusting
+ * before proceeding with further jump fixups (the interleaved nature of
+ * all the jumps makes this impossible to do without nested loops).
+ */
+
+ for (i=fixupCount-1 ; i>=0 ; i--) {
+ if (TclFixupForwardJump(envPtr, &fixupArray[i],
+ fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
+ int j;
+
+ for (j=i-1 ; j>=0 ; j--) {
+ if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
+ fixupTargetArray[j] += 3;
+ }
+ }
+ }
+ }
+ TclStackFree(interp, fixupTargetArray);
+ TclStackFree(interp, fixupArray);
+
+ envPtr->currStackDepth = savedStackDepth + 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IssueSwitchJumpTable --
+ *
+ * Generate instructions for a [switch] command that is to be compiled
+ * into a jump table. This only handles the case where case-sensitive,
+ * exact matching is used, but this is actually the most common case in
+ * real code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
+ int *bodyLines, /* Array of line numbers for body list
+ * items. */
+ int **bodyContLines) /* Array of continuation line info. */
+{
+ JumptableInfo *jtPtr;
+ 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
+ * table itself is independent of any invokation of the bytecode, and as
+ * such is stored in an auxData block.
+ *
+ * Start by allocating the jump table itself, plus some workspace.
+ */
+
+ jtPtr = ckalloc(sizeof(JumptableInfo));
+ Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
+ infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
+ finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
+ foundDefault = 0;
+ mustGenerate = 1;
+
+ /*
+ * Next, issue the instruction to do the jump, together with what we want
+ * to do if things do not work out (jump to either the default clause or
+ * the "default" default, which just sets the result to empty). Note that
+ * we will come back and rewrite the jump's offset parameter when we know
+ * what it should be, and that all jumps we issue are of the wide kind
+ * because that makes the code much easier to debug!
+ */
+
+ jumpLocation = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
+ jumpToDefault = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+
+ for (i=0 ; i<numBodyTokens ; i+=2) {
+ /*
+ * For each arm, we must first work out what to do with the match
+ * term.
+ */
+
+ if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
+ memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
+ /*
+ * This is not a default clause, so insert the current location as
+ * a target in the jump table (assuming it isn't already there,
+ * which would indicate that this clause is probably masked by an
+ * earlier one). Note that we use a Tcl_DString here simply
+ * because the hash API does not let us specify the string length.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, bodyToken[i]->start,
+ bodyToken[i]->size);
+ hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
+ Tcl_DStringValue(&buffer), &isNew);
+ if (isNew) {
+ /*
+ * First time we've encountered this match clause, so it must
+ * point to here.
+ */
+
+ Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation);
+ }
+ Tcl_DStringFree(&buffer);
+ } else {
+ /*
+ * This is a default clause, so patch up the fallthrough from the
+ * INST_JUMP_TABLE instruction to here.
+ */
+
+ foundDefault = 1;
+ isNew = 1;
+ TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
+ envPtr->codeStart+jumpToDefault+1);
+ }
+
+ /*
+ * Now, for each arm we must deal with the body of the clause.
+ *
+ * If this is a continuation body (never true of a final clause,
+ * whether default or not) we're done because the next jump target
+ * will also point here, so we advance to the next clause.
+ */
+
+ if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
+ mustGenerate = 1;
+ continue;
+ }
+
+ /*
+ * Also skip this arm if its only match clause is masked. (We could
+ * probably be more aggressive about this, but that would be much more
+ * difficult to get right.)
+ */
+
+ if (!isNew && !mustGenerate) {
+ continue;
+ }
+ mustGenerate = 0;
+
+ /*
+ * Compile the body of the arm.
+ */
+
+ envPtr->line = bodyLines[i+1]; /* TIP #280 */
+ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
+ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
+
+ /*
+ * Compile a jump in to the end of the command if this body is
+ * anything other than a user-supplied default arm (to either skip
+ * over the remaining bodies or the code that generates an empty
+ * result).
+ */
+
+ if (i+2 < numBodyTokens || !foundDefault) {
+ finalFixups[numRealBodies++] = CurrentOffset(envPtr);
+
+ /*
+ * Easier by far to issue this jump as a fixed-width jump, since
+ * otherwise we'd need to do a lot more (and more awkward)
+ * rewriting when we fixed this all up.
+ */
+
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+ }
+ }
+
+ /*
+ * We're at the end. If we've not already done so through the processing
+ * of a user-supplied default clause, add in a "default" default clause
+ * now.
+ */
+
+ if (!foundDefault) {
+ TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
+ envPtr->codeStart+jumpToDefault+1);
+ PushLiteral(envPtr, "", 0);
+ }
+
+ /*
+ * No more instructions to be issued; everything that needs to jump to the
+ * end of the command is fixed up at this point.
+ */
+
+ for (i=0 ; i<numRealBodies ; i++) {
+ TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
+ envPtr->codeStart+finalFixups[i]+1);
+ }
+
+ /*
+ * Clean up all our temporary space and return.
+ */
+
+ TclStackFree(interp, finalFixups);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupJumptableInfo, FreeJumptableInfo --
+ *
+ * Functions to duplicate, release and print a jump-table created for use
+ * with the INST_JUMP_TABLE instruction.
+ *
+ * Results:
+ * DupJumptableInfo: a copy of the jump-table
+ * FreeJumptableInfo: none
+ * PrintJumptableInfo: none
+ *
+ * Side effects:
+ * DupJumptableInfo: allocates memory
+ * FreeJumptableInfo: releases memory
+ * PrintJumptableInfo: none
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ClientData
+DupJumptableInfo(
+ ClientData clientData)
+{
+ JumptableInfo *jtPtr = clientData;
+ JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo));
+ Tcl_HashEntry *hPtr, *newHPtr;
+ Tcl_HashSearch search;
+ int isNew;
+
+ Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
+ hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+ while (hPtr != NULL) {
+ newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
+ Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
+ Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
+ }
+ return newJtPtr;
+}
+
+static void
+FreeJumptableInfo(
+ ClientData clientData)
+{
+ JumptableInfo *jtPtr = clientData;
+
+ Tcl_DeleteHashTable(&jtPtr->hashTable);
+ ckfree(jtPtr);
+}
+
+static void
+PrintJumptableInfo(
+ ClientData clientData,
+ Tcl_Obj *appendObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register JumptableInfo *jtPtr = clientData;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ const char *keyPtr;
+ int offset, i = 0;
+
+ hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+ for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
+ keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ offset = PTR2INT(Tcl_GetHashValue(hPtr));
+
+ if (i++) {
+ Tcl_AppendToObj(appendObj, ", ", -1);
+ if (i%4==0) {
+ Tcl_AppendToObj(appendObj, "\n\t\t", -1);
+ }
+ }
+ Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
+ keyPtr, pcOffset + offset);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileThrowCmd --
+ *
+ * Procedure called to compile the "throw" 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 "throw" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileThrowCmd(
+ 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 */
+ int numWords = parsePtr->numWords;
+ Tcl_Token *codeToken, *msgToken;
+ Tcl_Obj *objPtr;
+
+ if (numWords != 3) {
+ return TCL_ERROR;
+ }
+ codeToken = TokenAfter(parsePtr->tokenPtr);
+ msgToken = TokenAfter(codeToken);
+
+ 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.
+ */
+
+ 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.
+ */
+
+ CompileWord(envPtr, msgToken, interp, 2);
+ TclCompileSyntaxError(interp, envPtr);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_OK;
+ }
+ if (len == 0) {
+ /*
+ * Must still do this; might generate an error when getting this
+ * "ignored" value prepared as an argument.
+ */
+
+ 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);
+ } 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.
+ */
+
+ 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);
+
+ /*
+ * Generate an error for being an empty list. Can't leverage anything
+ * else to do this for us.
+ */
+
+ issueErrorForEmptyCode:
+ PUSH( "type must be non-empty list");
+ PUSH( "");
+ OP44( RETURN_IMM, 1, 0);
+ }
+ TclDecrRefCount(objPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileTryCmd --
+ *
+ * Procedure called to compile the "try" 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 "try" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileTryCmd(
+ 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. */
+{
+ int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
+ Tcl_Token *bodyToken, *finallyToken, *tokenPtr;
+ Tcl_Token **handlerTokens = NULL;
+ Tcl_Obj **matchClauses = NULL;
+ int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL;
+ int i;
+
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ bodyToken = TokenAfter(parsePtr->tokenPtr);
+
+ if (numWords == 2) {
+ /*
+ * No handlers or finally; do nothing beyond evaluating the body.
+ */
+
+ DefineLineInformation; /* TIP #280 */
+ SetLineInformation(1);
+ CompileBody(envPtr, bodyToken, interp);
+ return TCL_OK;
+ }
+
+ numWords -= 2;
+ tokenPtr = TokenAfter(bodyToken);
+
+ /*
+ * Extract information about what handlers there are.
+ */
+
+ numHandlers = numWords >> 2;
+ numWords -= numHandlers * 4;
+ if (numHandlers > 0) {
+ handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
+ matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
+ memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
+ matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers);
+ resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
+ optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
+
+ for (i=0 ; i<numHandlers ; i++) {
+ Tcl_Obj *tmpObj, **objv;
+ int objc;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ goto failedToCompile;
+ }
+ if (tokenPtr[1].size == 4
+ && !strncmp(tokenPtr[1].start, "trap", 4)) {
+ /*
+ * Parse the list of errorCode words to match against.
+ */
+
+ matchCodes[i] = TCL_ERROR;
+ tokenPtr = TokenAfter(tokenPtr);
+ TclNewObj(tmpObj);
+ Tcl_IncrRefCount(tmpObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
+ || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK
+ || (objc == 0)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL);
+ matchClauses[i] = tmpObj;
+ } else if (tokenPtr[1].size == 2
+ && !strncmp(tokenPtr[1].start, "on", 2)) {
+ int code;
+
+ /*
+ * Parse the result code to look for.
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ TclNewObj(tmpObj);
+ Tcl_IncrRefCount(tmpObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ matchCodes[i] = code;
+ TclDecrRefCount(tmpObj);
+ } else {
+ goto failedToCompile;
+ }
+
+ /*
+ * Parse the variable binding.
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ TclNewObj(tmpObj);
+ Tcl_IncrRefCount(tmpObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
+ || (objc > 2)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ if (objc > 0) {
+ int len;
+ const char *varname = Tcl_GetStringFromObj(objv[0], &len);
+
+ if (!TclIsLocalScalar(varname, len)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ resultVarIndices[i] =
+ TclFindCompiledLocal(varname, len, 1, envPtr);
+ } else {
+ resultVarIndices[i] = -1;
+ }
+ if (objc == 2) {
+ int len;
+ const char *varname = Tcl_GetStringFromObj(objv[1], &len);
+
+ if (!TclIsLocalScalar(varname, len)) {
+ TclDecrRefCount(tmpObj);
+ goto failedToCompile;
+ }
+ optionVarIndices[i] =
+ TclFindCompiledLocal(varname, len, 1, envPtr);
+ } else {
+ optionVarIndices[i] = -1;
+ }
+ TclDecrRefCount(tmpObj);
+
+ /*
+ * Extract the body for this handler.
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ goto failedToCompile;
+ }
+ if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') {
+ handlerTokens[i] = NULL;
+ } else {
+ handlerTokens[i] = tokenPtr;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ if (handlerTokens[numHandlers-1] == NULL) {
+ goto failedToCompile;
+ }
+ }
+
+ /*
+ * Parse the finally clause
+ */
+
+ if (numWords == 0) {
+ finallyToken = NULL;
+ } else if (numWords == 2) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7
+ || strncmp(tokenPtr[1].start, "finally", 7)) {
+ goto failedToCompile;
+ }
+ finallyToken = TokenAfter(tokenPtr);
+ } else {
+ goto failedToCompile;
+ }
+
+ /*
+ * Issue the bytecode.
+ */
+
+ if (finallyToken) {
+ result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
+ numHandlers, matchCodes, matchClauses, resultVarIndices,
+ optionVarIndices, handlerTokens, finallyToken);
+ } else {
+ result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers,
+ matchCodes, matchClauses, resultVarIndices, optionVarIndices,
+ handlerTokens);
+ }
+
+ /*
+ * Delete any temporary state and finish off.
+ */
+
+ failedToCompile:
+ if (numHandlers > 0) {
+ for (i=0 ; i<numHandlers ; i++) {
+ if (matchClauses[i]) {
+ TclDecrRefCount(matchClauses[i]);
+ }
+ }
+ TclStackFree(interp, optionVarIndices);
+ TclStackFree(interp, resultVarIndices);
+ TclStackFree(interp, matchCodes);
+ TclStackFree(interp, matchClauses);
+ TclStackFree(interp, handlerTokens);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IssueTryInstructions, 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.
+ *
+ * The macros below make the instruction issuing easier to follow.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+IssueTryInstructions(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr,
+ Tcl_Token *bodyToken,
+ int numHandlers,
+ int *matchCodes,
+ Tcl_Obj **matchClauses,
+ int *resultVars,
+ int *optionVars,
+ Tcl_Token **handlerTokens)
+{
+ DefineLineInformation; /* TIP #280 */
+ int range, resultVar, optionsVar;
+ int i, j, len, forwardsNeedFixing = 0;
+ int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
+ char buf[TCL_INTEGER_SPACE];
+
+ resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (resultVar < 0 || optionsVar < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( bodyToken, 1);
+ ExceptionRangeEnds(envPtr, range);
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RETURN_CODE);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( END_CATCH);
+ STORE( optionsVar);
+ OP( POP);
+ STORE( resultVar);
+ OP( POP);
+
+ /*
+ * Now we handle all the registered 'on' and 'trap' handlers in order.
+ * For us to be here, there must be at least one handler.
+ *
+ * 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);
+
+ /*
+ * Match the errorcode according to try/trap rules.
+ */
+
+ LOAD( optionsVar);
+ PUSH( "-errorcode");
+ OP4( DICT_GET, 1);
+ OP44( LIST_RANGE_IMM, 0, len-1);
+ PUSH( TclGetString(matchClauses[i]));
+ OP( STR_EQ);
+ JUMP(notECJumpSource, JUMP_FALSE4);
+ } else {
+ notECJumpSource = -1; /* LINT */
+ }
+ OP( POP);
+
+ /*
+ * There is no finally clause, so we can avoid wrapping a catch
+ * context around the handler. That simplifies what instructions need
+ * to be issued a lot since we can let errors just fall through.
+ */
+
+ 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]) {
+ forwardsNeedFixing = 1;
+ JUMP(forwardsToFix[i], JUMP4);
+ } else {
+ forwardsToFix[i] = -1;
+ if (forwardsNeedFixing) {
+ forwardsNeedFixing = 0;
+ for (j=0 ; j<i ; j++) {
+ if (forwardsToFix[j] == -1) {
+ continue;
+ }
+ FIXJUMP(forwardsToFix[j]);
+ forwardsToFix[j] = -1;
+ }
+ }
+ BODY( handlerTokens[i], 5+i*4);
+ }
+
+ JUMP(addrsToFix[i], JUMP4);
+ if (matchClauses[i]) {
+ FIXJUMP(notECJumpSource);
+ }
+ FIXJUMP(notCodeJumpSource);
+ }
+
+ /*
+ * Drop the result code since it didn't match any clause, and reissue the
+ * exception. Note also that INST_RETURN_STK can proceed to the next
+ * instruction.
+ */
+
+ OP( POP);
+ LOAD( optionsVar);
+ LOAD( resultVar);
+ OP( RETURN_STK);
+
+ /*
+ * Fix all the jumps from taken clauses to here (which is the end of the
+ * [try]).
+ */
+
+ for (i=0 ; i<numHandlers ; i++) {
+ FIXJUMP(addrsToFix[i]);
+ }
+ TclStackFree(interp, forwardsToFix);
+ TclStackFree(interp, addrsToFix);
+ return TCL_OK;
+}
+
+static int
+IssueTryFinallyInstructions(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr,
+ Tcl_Token *bodyToken,
+ int numHandlers,
+ int *matchCodes,
+ Tcl_Obj **matchClauses,
+ int *resultVars,
+ int *optionVars,
+ Tcl_Token **handlerTokens,
+ Tcl_Token *finallyToken) /* Not NULL */
+{
+ DefineLineInformation; /* TIP #280 */
+ int savedStackDepth = envPtr->currStackDepth;
+ int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
+ int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
+ char buf[TCL_INTEGER_SPACE];
+
+ resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (resultVar < 0 || optionsVar < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( bodyToken, 1);
+ ExceptionRangeEnds(envPtr, range);
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RETURN_CODE);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( END_CATCH);
+ STORE( optionsVar);
+ OP( POP);
+ STORE( resultVar);
+ OP( POP);
+ envPtr->currStackDepth = savedStackDepth + 1;
+
+ /*
+ * Now we handle all the registered 'on' and 'trap' handlers in order.
+ */
+
+ 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);
+
+ /*
+ * Match the errorcode according to try/trap rules.
+ */
+
+ LOAD( optionsVar);
+ PUSH( "-errorcode");
+ OP4( DICT_GET, 1);
+ OP44( LIST_RANGE_IMM, 0, len-1);
+ PUSH( TclGetString(matchClauses[i]));
+ OP( STR_EQ);
+ JUMP(notECJumpSource, JUMP_FALSE4);
+ } else {
+ notECJumpSource = -1; /* LINT */
+ }
+
+ /*
+ * 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.
+ */
+
+ 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);
+ }
+
+ 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.
+ */
+
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
+ forwardsNeedFixing = 1;
+ JUMP(forwardsToFix[i], JUMP4);
+ goto finishTrapCatchHandling;
+ }
+ } else if (!handlerTokens[i]) {
+ /*
+ * No handler. Will not be the last handler (that condition is
+ * checked by the caller). Chain to the next one.
+ */
+
+ forwardsNeedFixing = 1;
+ JUMP(forwardsToFix[i], JUMP4);
+ goto endOfThisArm;
+ }
+
+ /*
+ * 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.
+ */
+
+ 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);
+ }
+ 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.
+ */
+
+ finishTrapCatchHandling:
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RESULT);
+ OP( END_CATCH);
+ STORE( resultVar);
+ OP( POP);
+ STORE( optionsVar);
+ OP( POP);
+
+ endOfThisArm:
+ if (i+1 < numHandlers) {
+ JUMP(addrsToFix[i], JUMP4);
+ }
+ if (matchClauses[i]) {
+ FIXJUMP(notECJumpSource);
+ }
+ FIXJUMP(notCodeJumpSource);
+ }
+
+ /*
+ * Fix all the jumps from taken clauses to here (the start of the
+ * finally clause).
+ */
+
+ for (i=0 ; i<numHandlers-1 ; i++) {
+ FIXJUMP(addrsToFix[i]);
+ }
+ TclStackFree(interp, forwardsToFix);
+ TclStackFree(interp, addrsToFix);
+ }
+
+ /*
+ * Drop the result code.
+ */
+
+ OP( POP);
+ envPtr->currStackDepth = savedStackDepth;
+
+ /*
+ * Process the finally clause (at last!) Note that we do not wrap this in
+ * error handlers because we would just rethrow immediately anyway. Then
+ * (on normal success) we reissue the exception. Note also that
+ * INST_RETURN_STK can proceed to the next instruction; that'll be the
+ * next command (or some inter-command manipulation).
+ */
+
+ BODY( finallyToken, 3 + 4*numHandlers);
+ OP( POP);
+ LOAD( optionsVar);
+ LOAD( resultVar);
+ OP( RETURN_STK);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileUnsetCmd --
+ *
+ * Procedure called to compile the "unset" 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 "unset" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileUnsetCmd(
+ 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 isScalar, simpleVarName, localIndex, numWords, flags, i;
+ Tcl_Obj *leadingWord;
+ 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.
+ */
+
+ TclDecrRefCount(leadingWord);
+ return TCL_ERROR;
+ }
+ TclDecrRefCount(leadingWord);
+
+ for (i=0 ; i<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
+ * 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.
+ */
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+
+ /*
+ * Emit instructions to unset the variable.
+ */
+
+ if (!simpleVarName) {
+ TclEmitInstInt1( INST_UNSET_STK, flags, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitInstInt1(INST_UNSET_STK, flags, envPtr);
+ } else {
+ TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr);
+ } else {
+ TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ }
+ }
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileWhileCmd --
+ *
+ * Procedure called to compile the "while" 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 "while" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileWhileCmd(
+ 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 *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;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the test expression requires substitutions, don't compile the while
+ * command inline. E.g., the expression might cause the loop to never
+ * execute or execute forever, as in "while "$x < 5" {}".
+ *
+ * Bail out also if the body expression requires substitutions in order to
+ * insure correct behaviour [Bug 219166]
+ */
+
+ testTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ bodyTokenPtr = TokenAfter(testTokenPtr);
+
+ if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
+ || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find out if the condition is a constant.
+ */
+
+ boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
+ Tcl_IncrRefCount(boolObj);
+ code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
+ TclDecrRefCount(boolObj);
+ if (code == TCL_OK) {
+ if (boolVal) {
+ /*
+ * It is an infinite loop; flag it so that we generate a more
+ * efficient body.
+ */
+
+ loopMayEnd = 0;
+ } else {
+ /*
+ * This is an empty loop: "while 0 {...}" or such. Compile no
+ * bytecodes.
+ */
+
+ goto pushResult;
+ }
+ }
+
+ /*
+ * Create a ExceptionRange record for the loop body. This is used to
+ * implement break and continue.
+ */
+
+ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+
+ /*
+ * Jump to the evaluation of the condition. This code uses the "loop
+ * rotation" optimisation (which eliminates one branch from the loop).
+ * "while cond body" produces then:
+ * goto A
+ * B: body : bodyCodeOffset
+ * A: cond -> result : testCodeOffset, continueOffset
+ * if (result) goto B
+ *
+ * The infinite loop "while 1 body" produces:
+ * B: body : all three offsets here
+ * goto B
+ */
+
+ if (loopMayEnd) {
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &jumpEvalCondFixup);
+ testCodeOffset = 0; /* Avoid compiler warning. */
+ } else {
+ /*
+ * Make sure that the first command in the body is preceded by an
+ * INST_START_CMD, and hence counted properly. [Bug 1752146]
+ */
+
+ envPtr->atCmdStart = 0;
+ testCodeOffset = CurrentOffset(envPtr);
+ }
+
+ /*
+ * Compile the loop body.
+ */
+
+ SetLineInformation(2);
+ bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
+ envPtr->currStackDepth = savedStackDepth + 1;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Compile the test expression then emit the conditional jump that
+ * terminates the while. We already know it's a simple word.
+ */
+
+ if (loopMayEnd) {
+ testCodeOffset = CurrentOffset(envPtr);
+ jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ bodyCodeOffset += 3;
+ testCodeOffset += 3;
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ SetLineInformation(1);
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
+
+ jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
+ if (jumpDist > 127) {
+ TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
+ }
+ } else {
+ jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
+ if (jumpDist > 127) {
+ TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
+ }
+ }
+
+ /*
+ * Set the loop's body, continue and break offsets.
+ */
+
+ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+ envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
+ ExceptionRangeTarget(envPtr, range, breakOffset);
+
+ /*
+ * The while command's result is an empty string.
+ */
+
+ pushResult:
+ envPtr->currStackDepth = savedStackDepth;
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * 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 compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileUnaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode(instruction, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileAssociativeBinaryOpCmd --
+ *
+ * Utility routine to compile the binary operator commands that accept an
+ * arbitrary number of arguments, and that are associative operations.
+ * Because of the associativity, we may combine operations from right to
+ * left, saving us any effort of re-ordering the arguments on the stack
+ * after substitutions are completed.
+ *
+ * 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 compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileAssociativeBinaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ const char *identity,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (parsePtr->numWords <= 2) {
+ PushLiteral(envPtr, identity, -1);
+ words++;
+ }
+ if (words > 3) {
+ /*
+ * Reverse order of arguments to get precise agreement with [expr] in
+ * calcuations, including roundoff errors.
+ */
+
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ }
+ while (--words > 1) {
+ TclEmitOpcode(instruction, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileStrictlyBinaryOpCmd --
+ *
+ * Utility routine to compile the binary operator commands, that strictly
+ * accept exactly two arguments.
+ *
+ * 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 compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileStrictlyBinaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr,
+ NULL, instruction, envPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileComparisonOpCmd --
+ *
+ * Utility routine to compile the n-ary comparison operator commands.
+ *
+ * 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 compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileComparisonOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords < 3) {
+ PushLiteral(envPtr, "1", 1);
+ } else if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(instruction, envPtr);
+ } else if (envPtr->procPtr == NULL) {
+ /*
+ * No local variable space!
+ */
+
+ return TCL_ERROR;
+ } else {
+ int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ int words;
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(instruction, envPtr);
+ for (words=3 ; words<parsePtr->numWords ;) {
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ if (++words < parsePtr->numWords) {
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ }
+ TclEmitOpcode(instruction, envPtr);
+ }
+ for (; words>3 ; words--) {
+ TclEmitOpcode(INST_BITAND, envPtr);
+ }
+
+ /*
+ * Drop the value from the temp variable; retaining that reference
+ * might be expensive elsewhere.
+ */
+
+ PushLiteral(envPtr, "", 0);
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompile*OpCmd --
+ *
+ * Procedures called to compile the corresponding "::tcl::mathop::*"
+ * commands. These are all wrappers around the utility operator command
+ * compiler functions, except for the compilers for subtraction and
+ * division, which are special.
+ *
+ * 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 compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileInvertOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
+}
+
+int
+TclCompileNotOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
+}
+
+int
+TclCompileAddOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
+ envPtr);
+}
+
+int
+TclCompileMulOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
+ envPtr);
+}
+
+int
+TclCompileAndOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
+ envPtr);
+}
+
+int
+TclCompileOrOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
+ envPtr);
+}
+
+int
+TclCompileXorOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
+ envPtr);
+}
+
+int
+TclCompilePowOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ /*
+ * This one has its own implementation because the ** operator is the only
+ * one with right associativity.
+ */
+
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (parsePtr->numWords <= 2) {
+ PushLiteral(envPtr, "1", 1);
+ words++;
+ }
+ while (--words > 1) {
+ TclEmitOpcode(INST_EXPON, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileLshiftOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
+}
+
+int
+TclCompileRshiftOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
+}
+
+int
+TclCompileModOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
+}
+
+int
+TclCompileNeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
+}
+
+int
+TclCompileStrneqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
+}
+
+int
+TclCompileInOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
+}
+
+int
+TclCompileNiOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
+ envPtr);
+}
+
+int
+TclCompileLessOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
+}
+
+int
+TclCompileLeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
+}
+
+int
+TclCompileGreaterOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
+}
+
+int
+TclCompileGeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
+}
+
+int
+TclCompileEqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
+}
+
+int
+TclCompileStreqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
+}
+
+int
+TclCompileMinusOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Fallback to direct eval to report syntax error.
+ */
+
+ return TCL_ERROR;
+ }
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (words == 2) {
+ TclEmitOpcode(INST_UMINUS, envPtr);
+ return TCL_OK;
+ }
+ if (words == 3) {
+ TclEmitOpcode(INST_SUB, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Reverse order of arguments to get precise agreement with [expr] in
+ * calcuations, including roundoff errors.
+ */
+
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_SUB, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileDivOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Fallback to direct eval to report syntax error.
+ */
+
+ return TCL_ERROR;
+ }
+ if (parsePtr->numWords == 2) {
+ PushLiteral(envPtr, "1.0", 3);
+ }
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (words <= 3) {
+ TclEmitOpcode(INST_DIV, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Reverse order of arguments to get precise agreement with [expr] in
+ * calcuations, including roundoff errors.
+ */
+
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_DIV, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d5300db..d1d7403 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -1,8 +1,8 @@
/*
* tclCompExpr.c --
*
- * This file contains the code to parse and compile Tcl expressions
- * and implementations of the Tcl commands corresponding to expression
+ * This file contains the code to parse and compile Tcl expressions and
+ * implementations of the Tcl commands corresponding to expression
* operators, such as the command ::tcl::mathop::+ .
*
* Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright)
@@ -15,11 +15,11 @@
#include "tclCompile.h" /* CompileEnv */
/*
- * Expression parsing takes place in the routine ParseExpr(). It takes a
- * string as input, parses that string, and generates a representation of
- * the expression in the form of a tree of operators, a list of literals,
- * a list of function names, and an array of Tcl_Token's within a Tcl_Parse
- * struct. The tree is composed of OpNodes.
+ * Expression parsing takes place in the routine ParseExpr(). It takes a
+ * string as input, parses that string, and generates a representation of the
+ * expression in the form of a tree of operators, a list of literals, a list
+ * of function names, and an array of Tcl_Token's within a Tcl_Parse struct.
+ * The tree is composed of OpNodes.
*/
typedef struct OpNode {
@@ -36,36 +36,36 @@ typedef struct OpNode {
} OpNode;
/*
- * The storage for the tree is dynamically allocated array of OpNodes. The
+ * The storage for the tree is dynamically allocated array of OpNodes. The
* array is grown as parsing needs dictate according to a scheme similar to
* Tcl's string growth algorithm, so that the resizing costs are O(N) and so
* that we use at least half the memory allocated as expressions get large.
*
* Each OpNode in the tree represents an operator in the expression, either
- * unary or binary. When parsing is completed successfully, a binary operator
+ * unary or binary. When parsing is completed successfully, a binary operator
* OpNode will have its left and right fields filled with "pointers" to its
- * left and right operands. A unary operator OpNode will have its right field
- * filled with a pointer to its single operand. When an operand is a
+ * left and right operands. A unary operator OpNode will have its right field
+ * filled with a pointer to its single operand. When an operand is a
* subexpression the "pointer" takes the form of the index -- a non-negative
* integer -- into the OpNode storage array where the root of that
* subexpression parse tree is found.
*
* Non-operator elements of the expression do not get stored in the OpNode
- * tree. They are stored in the other structures according to their type.
- * Literal values get appended to the literal list. Elements that denote
- * forms of quoting or substitution known to the Tcl parser get stored as
- * Tcl_Tokens. These non-operator elements of the expression are the
- * leaves of the completed parse tree. When an operand of an OpNode is
- * one of these leaf elements, the following negative integer codes are used
- * to indicate which kind of elements it is.
+ * tree. They are stored in the other structures according to their type.
+ * Literal values get appended to the literal list. Elements that denote forms
+ * of quoting or substitution known to the Tcl parser get stored as
+ * Tcl_Tokens. These non-operator elements of the expression are the leaves of
+ * the completed parse tree. When an operand of an OpNode is one of these leaf
+ * elements, the following negative integer codes are used to indicate which
+ * kind of elements it is.
*/
enum OperandTypes {
OT_LITERAL = -3, /* Operand is a literal in the literal list */
OT_TOKENS = -2, /* Operand is sequence of Tcl_Tokens */
- OT_EMPTY = -1 /* "Operand" is an empty string. This is a
- * special case used only to represent the
- * EMPTY lexeme. See below. */
+ OT_EMPTY = -1 /* "Operand" is an empty string. This is a special
+ * case used only to represent the EMPTY lexeme. See
+ * below. */
};
/*
@@ -79,31 +79,30 @@ enum OperandTypes {
/*
* Note that it is sufficient to store in the tree just the type of leaf
- * operand, without any explicit pointer to which leaf. This is true because
- * the traversals of the completed tree we perform are known to visit
- * the leaves in the same order as the original parse.
+ * operand, without any explicit pointer to which leaf. This is true because
+ * the traversals of the completed tree we perform are known to visit the
+ * leaves in the same order as the original parse.
*
* In a completed parse tree, those OpNodes that are themselves (roots of
* subexpression trees that are) operands of some operator store in their
- * p.parent field a "pointer" to the OpNode of that operator. The p.parent
- * field permits a traversal of the tree within a * non-recursive routine
- * (ConvertTreeToTokens() and CompileExprTree()). This means that even
+ * p.parent field a "pointer" to the OpNode of that operator. The p.parent
+ * field permits a traversal of the tree within a non-recursive routine
+ * (ConvertTreeToTokens() and CompileExprTree()). This means that even
* expression trees of great depth pose no risk of blowing the C stack.
*
- * While the parse tree is being constructed, the same memory space is used
- * to hold the p.prev field which chains together a stack of incomplete
- * trees awaiting their right operands.
+ * While the parse tree is being constructed, the same memory space is used to
+ * hold the p.prev field which chains together a stack of incomplete trees
+ * awaiting their right operands.
*
* The lexeme field is filled in with the lexeme of the operator that is
- * returned by the ParseLexeme() routine. Only lexemes for unary and
- * binary operators get stored in an OpNode. Other lexmes get different
- * treatement.
+ * returned by the ParseLexeme() routine. Only lexemes for unary and binary
+ * operators get stored in an OpNode. Other lexmes get different treatement.
*
* The precedence field provides a place to store the precedence of the
* operator, so it need not be looked up again and again.
*
- * The mark field is use to control the traversal of the tree, so
- * that it can be done non-recursively. The mark values are:
+ * The mark field is use to control the traversal of the tree, so that it can
+ * be done non-recursively. The mark values are:
*/
enum Marks {
@@ -119,52 +118,51 @@ enum Marks {
*/
/*
- * Each lexeme belongs to one of four categories, which determine
- * its place in the parse tree. We use the two high bits of the
- * (unsigned char) value to store a NODE_TYPE code.
+ * Each lexeme belongs to one of four categories, which determine its place in
+ * the parse tree. We use the two high bits of the (unsigned char) value to
+ * store a NODE_TYPE code.
*/
#define NODE_TYPE 0xC0
/*
- * The four category values are LEAF, UNARY, and BINARY, explained below,
- * and "uncategorized", which is used either temporarily, until context
- * determines which of the other three categories is correct, or for
- * lexemes like INVALID, which aren't really lexemes at all, but indicators
- * of a parsing error. Note that the codes must be distinct to distinguish
- * categories, but need not take the form of a bit array.
+ * The four category values are LEAF, UNARY, and BINARY, explained below, and
+ * "uncategorized", which is used either temporarily, until context determines
+ * which of the other three categories is correct, or for lexemes like
+ * INVALID, which aren't really lexemes at all, but indicators of a parsing
+ * error. Note that the codes must be distinct to distinguish categories, but
+ * need not take the form of a bit array.
*/
-#define BINARY 0x40 /* This lexeme is a binary operator. An
- * OpNode representing it should go into the
- * parse tree, and two operands should be
- * parsed for it in the expression. */
-#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode
+#define BINARY 0x40 /* This lexeme is a binary operator. An OpNode
+ * representing it should go into the parse
+ * tree, and two operands should be parsed for
+ * it in the expression. */
+#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode
* representing it should go into the parse
* tree, and one operand should be parsed for
* it in the expression. */
#define LEAF 0xC0 /* This lexeme is a leaf operand in the parse
- * tree. No OpNode will be placed in the tree
- * for it. Either a literal value will be
+ * tree. No OpNode will be placed in the tree
+ * for it. Either a literal value will be
* appended to the list of literals in this
* expression, or appropriate Tcl_Tokens will
* be appended in a Tcl_Parse struct to
* represent those leaves that require some
- * form of substitution.
- */
+ * form of substitution. */
/* Uncategorized lexemes */
-#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or
+#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or
* BINARY_PLUS according to context. */
-#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or
+#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or
* BINARY_MINUS according to context. */
-#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to
+#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to
* FUNCTION or a parse error according to
* context and value. */
-#define INCOMPLETE 4 /* A parse error. Used only when the single
+#define INCOMPLETE 4 /* A parse error. Used only when the single
* "=" is encountered. */
-#define INVALID 5 /* A parse error. Used when any punctuation
+#define INVALID 5 /* A parse error. Used when any punctuation
* appears that's not a supported operator. */
/* Leaf lexemes */
@@ -176,9 +174,9 @@ enum Marks {
#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */
#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */
#define EMPTY ( LEAF | 7) /* Used only for an empty argument
- * list to a function. Represents
- * the empty string within parens in
- * the expression: rand() */
+ * list to a function. Represents the
+ * empty string within parens in the
+ * expression: rand() */
/* Unary operator lexemes */
@@ -186,28 +184,29 @@ enum Marks {
#define UNARY_MINUS ( UNARY | MINUS)
#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative
* interpretation" on the part of the
- * parser. A function call is parsed
+ * parser. A function call is parsed
* into the parse tree according to
* the perspective that the function
* name is a unary operator and its
* argument list, enclosed in parens,
- * is its operand. The additional
+ * is its operand. The additional
* requirements not implied generally
* by treatment as a unary operator --
* for example, the requirement that
- * the operand be enclosed in parens --
- * are hard coded in the relevant
- * portions of ParseExpr(). We trade
+ * the operand be enclosed in parens
+ * -- are hard coded in the relevant
+ * portions of ParseExpr(). We trade
* off the need to include such
* exceptional handling in the code
* against the need we would otherwise
* have for more lexeme categories. */
#define START ( UNARY | 4) /* This lexeme isn't parsed from the
- * expression text at all. It
+ * expression text at all. It
* represents the start of the
* expression and sits at the root of
* the parse tree where it serves as
- * the start/end point of traversals. */
+ * the start/end point of
+ * traversals. */
#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative
* interpretation, where we treat "("
* as a unary operator with the
@@ -221,14 +220,15 @@ enum Marks {
#define BINARY_PLUS ( BINARY | PLUS)
#define BINARY_MINUS ( BINARY | MINUS)
-#define COMMA ( BINARY | 3) /* The "," operator is a low precedence
- * binary operator that separates the
- * arguments in a function call. The
- * additional constraint that this
- * operator can only legally appear
- * at the right places within a
- * function call argument list are
- * hard coded within ParseExpr(). */
+#define COMMA ( BINARY | 3) /* The "," operator is a low
+ * precedence binary operator that
+ * separates the arguments in a
+ * function call. The additional
+ * constraint that this operator can
+ * only legally appear at the right
+ * places within a function call
+ * argument list are hard coded within
+ * ParseExpr(). */
#define MULT ( BINARY | 4)
#define DIVIDE ( BINARY | 5)
#define MOD ( BINARY | 6)
@@ -239,14 +239,13 @@ enum Marks {
#define BIT_OR ( BINARY | 11)
#define QUESTION ( BINARY | 12) /* These two lexemes make up the */
#define COLON ( BINARY | 13) /* ternary conditional operator,
- * $x ? $y : $z . We treat them as
- * two binary operators to avoid
- * another lexeme category, and
- * code the additional constraints
- * directly in ParseExpr(). For
- * instance, the right operand of
- * a "?" operator must be a ":"
- * operator. */
+ * $x ? $y : $z . We treat them as two
+ * binary operators to avoid another
+ * lexeme category, and code the
+ * additional constraints directly in
+ * ParseExpr(). For instance, the
+ * right operand of a "?" operator
+ * must be a ":" operator. */
#define LEFT_SHIFT ( BINARY | 14)
#define RIGHT_SHIFT ( BINARY | 15)
#define LEQ ( BINARY | 16)
@@ -273,23 +272,22 @@ enum Marks {
* operators according to precedence
* performs most of the work of
* matching open and close parens for
- * us. In the end though, a close
+ * us. In the end though, a close
* paren is not really a binary
* operator, and some special coding
* in ParseExpr() make sure we never
- * put an actual CLOSE_PAREN node
- * in the parse tree. The
- * sub-expression between parens
- * becomes the single argument of
- * the matching OPEN_PAREN unary
- * operator. */
+ * put an actual CLOSE_PAREN node in
+ * the parse tree. The sub-expression
+ * between parens becomes the single
+ * argument of the matching OPEN_PAREN
+ * unary operator. */
#define END ( BINARY | 28) /* This lexeme represents the end of
- * the string being parsed. Treating
+ * the string being parsed. Treating
* it as a binary operator follows the
- * same logic as the CLOSE_PAREN lexeme
- * and END pairs with START, in the
- * same way that CLOSE_PAREN pairs with
- * OPEN_PAREN. */
+ * same logic as the CLOSE_PAREN
+ * lexeme and END pairs with START, in
+ * the same way that CLOSE_PAREN pairs
+ * with OPEN_PAREN. */
/*
* When ParseExpr() builds the parse tree it must choose which operands to
* connect to which operators. This is done according to operator precedence.
@@ -323,7 +321,7 @@ enum Precedence {
/*
* Here the same information contained in the comments above is stored
- * in inverted form, so that given a lexeme, one can quickly look up
+ * in inverted form, so that given a lexeme, one can quickly look up
* its precedence value.
*/
@@ -367,7 +365,7 @@ static const unsigned char prec[] = {
0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0,
+ 0,
/* Unary operator lexemes */
PREC_UNARY, /* UNARY_PLUS */
PREC_UNARY, /* UNARY_MINUS */
@@ -422,7 +420,7 @@ static const unsigned char instruction[] = {
0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0,
+ 0,
/* Unary operator lexemes */
INST_UPLUS, /* UNARY_PLUS */
INST_UMINUS, /* UNARY_MINUS */
@@ -455,7 +453,7 @@ static unsigned char Lexeme[] = {
INVALID /* SUB */, INVALID /* ESC */,
INVALID /* FS */, INVALID /* GS */,
INVALID /* RS */, INVALID /* US */,
- INVALID /* SPACE */, 0 /* ! or != */,
+ INVALID /* SPACE */, 0 /* ! or != */,
QUOTED /* " */, INVALID /* # */,
VARIABLE /* $ */, MOD /* % */,
0 /* & or && */, INVALID /* ' */,
@@ -490,7 +488,7 @@ static unsigned char Lexeme[] = {
typedef struct JumpList {
JumpFixup jump; /* Pass this argument to matching calls of
- * TclEmitForwardJump() and
+ * TclEmitForwardJump() and
* TclFixupForwardJump(). */
int depth; /* Remember the currStackDepth of the
* CompileEnv here. */
@@ -521,7 +519,6 @@ static int ParseExpr(Tcl_Interp *interp, const char *start,
Tcl_Parse *parsePtr, int parseOnly);
static int ParseLexeme(const char *start, int numBytes,
unsigned char *lexemePtr, Tcl_Obj **literalPtr);
-
/*
*----------------------------------------------------------------------
@@ -529,27 +526,27 @@ static int ParseLexeme(const char *start, int numBytes,
* ParseExpr --
*
* Given a string, the numBytes bytes starting at start, this function
- * parses it as a Tcl expression and constructs a tree representing
- * the structure of the expression. The caller must pass in empty
- * lists as the funcList and litList arguments. The elements of the
- * parsed expression are returned to the caller as that tree, a list of
- * literal values, a list of function names, and in Tcl_Tokens
- * added to a Tcl_Parse struct passed in by the caller.
+ * parses it as a Tcl expression and constructs a tree representing the
+ * structure of the expression. The caller must pass in empty lists as
+ * the funcList and litList arguments. The elements of the parsed
+ * expression are returned to the caller as that tree, a list of literal
+ * values, a list of function names, and in Tcl_Tokens added to a
+ * Tcl_Parse struct passed in by the caller.
*
* Results:
* If the string is successfully parsed as a valid Tcl expression, TCL_OK
- * is returned, and data about the expression structure is written to
- * the last four arguments. If the string cannot be parsed as a valid
- * Tcl expression, TCL_ERROR is returned, and if interp is non-NULL, an
- * error message is written to interp.
+ * is returned, and data about the expression structure is written to the
+ * last four arguments. If the string cannot be parsed as a valid Tcl
+ * expression, TCL_ERROR is returned, and if interp is non-NULL, an error
+ * message is written to interp.
*
* Side effects:
- * Memory will be allocated. If TCL_OK is returned, the caller must
- * clean up the returned data structures. The (OpNode *) value written
- * to opTreePtr should be passed to ckfree() and the parsePtr argument
- * should be passed to Tcl_FreeParse(). The elements appended to the
- * litList and funcList will automatically be freed whenever the
- * refcount on those lists indicates they can be freed.
+ * Memory will be allocated. If TCL_OK is returned, the caller must clean
+ * up the returned data structures. The (OpNode *) value written to
+ * opTreePtr should be passed to ckfree() and the parsePtr argument
+ * should be passed to Tcl_FreeParse(). The elements appended to the
+ * litList and funcList will automatically be freed whenever the refcount
+ * on those lists indicates they can be freed.
*
*----------------------------------------------------------------------
*/
@@ -568,38 +565,39 @@ ParseExpr(
* substitutions. */
int parseOnly) /* A boolean indicating whether the caller's
* aim is just a parse, or whether it will go
- * on to compile the expression. Different
- * optimizations are appropriate for the
- * two scenarios. */
+ * on to compile the expression. Different
+ * optimizations are appropriate for the two
+ * scenarios. */
{
OpNode *nodes = NULL; /* Pointer to the OpNode storage array where
* we build the parse tree. */
- int nodesAvailable = 64; /* Initial size of the storage array. This
- * value establishes a minimum tree memory cost
- * of only about 1 kibyte, and is large enough
- * for most expressions to parse with no need
- * for array growth and reallocation. */
+ int nodesAvailable = 64; /* Initial size of the storage array. This
+ * value establishes a minimum tree memory
+ * cost of only about 1 kibyte, and is large
+ * enough for most expressions to parse with
+ * no need for array growth and
+ * reallocation. */
int nodesUsed = 0; /* Number of OpNodes filled. */
- int scanned = 0; /* Capture number of byte scanned by
- * parsing routines. */
+ int scanned = 0; /* Capture number of byte scanned by parsing
+ * routines. */
int lastParsed; /* Stores info about what the lexeme parsed
* the previous pass through the parsing loop
- * was. If it was an operator, lastParsed is
+ * was. If it was an operator, lastParsed is
* the index of the OpNode for that operator.
* If it was not an operator, lastParsed holds
- * an OperandTypes value encoding what we
- * need to know about it. */
- int incomplete; /* Index of the most recent incomplete tree
- * in the OpNode array. Heads a stack of
+ * an OperandTypes value encoding what we need
+ * to know about it. */
+ int incomplete; /* Index of the most recent incomplete tree in
+ * the OpNode array. Heads a stack of
* incomplete trees linked by p.prev. */
int complete = OT_EMPTY; /* "Index" of the complete tree (that is, a
* complete subexpression) determined at the
- * moment. OT_EMPTY is a nonsense value
- * used only to silence compiler warnings.
- * During a parse, complete will always hold
- * an index or an OperandTypes value pointing
- * to an actual leaf at the time the complete
- * tree is needed. */
+ * moment. OT_EMPTY is a nonsense value used
+ * only to silence compiler warnings. During a
+ * parse, complete will always hold an index
+ * or an OperandTypes value pointing to an
+ * actual leaf at the time the complete tree
+ * is needed. */
/* These variables control generation of the error message. */
Tcl_Obj *msg = NULL; /* The error message. */
@@ -607,29 +605,39 @@ ParseExpr(
* for the error message, supplying more
* information after the error msg and
* location have been reported. */
- const char *mark = "_@_"; /* In the portion of the complete error message
- * where the error location is reported, this
- * "mark" substring is inserted into the
- * string being parsed to aid in pinpointing
- * the location of the syntax error in the
- * expression. */
+ const char *errCode = NULL; /* The detail word of the errorCode list, or
+ * NULL to indicate that no changes to the
+ * errorCode are to be done. */
+ const char *subErrCode = NULL;
+ /* Extra information for use in generating the
+ * errorCode. */
+ const char *mark = "_@_"; /* In the portion of the complete error
+ * message where the error location is
+ * reported, this "mark" substring is inserted
+ * into the string being parsed to aid in
+ * pinpointing the location of the syntax
+ * error in the expression. */
int insertMark = 0; /* A boolean controlling whether the "mark"
* should be inserted. */
const int limit = 25; /* Portions of the error message are
* constructed out of substrings of the
- * original expression. In order to keep the
- * error message readable, we impose this limit
- * on the substring size we extract. */
+ * original expression. In order to keep the
+ * error message readable, we impose this
+ * limit on the substring size we extract. */
TclParseInit(interp, start, numBytes, parsePtr);
- nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode));
+ nodes = attemptckalloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
+ errCode = "NOMEM";
goto error;
}
- /* Initialize the parse tree with the special "START" node. */
+ /*
+ * Initialize the parse tree with the special "START" node.
+ */
+
nodes->lexeme = START;
nodes->precedence = prec[START];
nodes->mark = MARK_RIGHT;
@@ -638,25 +646,24 @@ ParseExpr(
nodesUsed++;
/*
- * Main parsing loop parses one lexeme per iteration. We exit the
- * loop only when there's a syntax error with a "goto error" which
- * takes us to the error handling code following the loop, or when
- * we've successfully completed the parse and we return to the caller.
+ * Main parsing loop parses one lexeme per iteration. We exit the loop
+ * only when there's a syntax error with a "goto error" which takes us to
+ * the error handling code following the loop, or when we've successfully
+ * completed the parse and we return to the caller.
*/
while (1) {
- OpNode *nodePtr; /* Points to the OpNode we may fill this
- * pass through the loop. */
+ OpNode *nodePtr; /* Points to the OpNode we may fill this pass
+ * through the loop. */
unsigned char lexeme; /* The lexeme we parse this iteration. */
- Tcl_Obj *literal; /* Filled by the ParseLexeme() call when
- * a literal is parsed that has a Tcl_Obj
- * rep worth preserving. */
+ Tcl_Obj *literal; /* Filled by the ParseLexeme() call when a
+ * literal is parsed that has a Tcl_Obj rep
+ * worth preserving. */
const char *lastStart = start - scanned;
/* Compute where the lexeme parsed the
- * previous pass through the loop began.
- * This is helpful for detecting invalid
- * octals and providing more complete error
- * messages. */
+ * previous pass through the loop began. This
+ * is helpful for detecting invalid octals and
+ * providing more complete error messages. */
/*
* Each pass through this loop adds up to one more OpNode. Allocate
@@ -668,13 +675,13 @@ ParseExpr(
OpNode *newPtr;
do {
- newPtr = (OpNode *) attemptckrealloc((char *) nodes,
- (unsigned int) size * sizeof(OpNode));
+ newPtr = attemptckrealloc(nodes, size * sizeof(OpNode));
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
if (newPtr == NULL) {
TclNewLiteralStringObj(msg,
"not enough memory to parse expression");
+ errCode = "NOMEM";
goto error;
}
nodesAvailable = size;
@@ -682,32 +689,41 @@ ParseExpr(
}
nodePtr = nodes + nodesUsed;
- /* Skip white space between lexemes. */
+ /*
+ * Skip white space between lexemes.
+ */
+
scanned = TclParseAllWhiteSpace(start, numBytes);
start += scanned;
numBytes -= scanned;
scanned = ParseLexeme(start, numBytes, &lexeme, &literal);
- /* Use context to categorize the lexemes that are ambiguous. */
+ /*
+ * Use context to categorize the lexemes that are ambiguous.
+ */
+
if ((NODE_TYPE & lexeme) == 0) {
+ int b;
+
switch (lexeme) {
case INVALID:
- msg = Tcl_ObjPrintf(
- "invalid character \"%.*s\"", scanned, start);
+ msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
+ scanned, start);
+ errCode = "BADCHAR";
goto error;
case INCOMPLETE:
- msg = Tcl_ObjPrintf(
- "incomplete operator \"%.*s\"", scanned, start);
+ msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"",
+ scanned, start);
+ errCode = "PARTOP";
goto error;
case BAREWORD:
/*
- * Most barewords in an expression are a syntax error.
- * The exceptions are that when a bareword is followed by
- * an open paren, it might be a function call, and when the
- * bareword is a legal literal boolean value, we accept that
- * as well.
+ * Most barewords in an expression are a syntax error. The
+ * exceptions are that when a bareword is followed by an open
+ * paren, it might be a function call, and when the bareword
+ * is a legal literal boolean value, we accept that as well.
*/
if (start[scanned+TclParseAllWhiteSpace(
@@ -722,61 +738,59 @@ ParseExpr(
*/
Tcl_ListObjAppendElement(NULL, funcList, literal);
+ } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
+ lexeme = BOOLEAN;
} else {
- int b;
- if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) {
- lexeme = BOOLEAN;
- } else {
- Tcl_DecrRefCount(literal);
- msg = Tcl_ObjPrintf(
- "invalid bareword \"%.*s%s\"",
- (scanned < limit) ? scanned : limit - 3, start,
- (scanned < limit) ? "" : "...");
- post = Tcl_ObjPrintf(
- "should be \"$%.*s%s\" or \"{%.*s%s}\"",
- (scanned < limit) ? scanned : limit - 3,
- start, (scanned < limit) ? "" : "...",
- (scanned < limit) ? scanned : limit - 3,
- start, (scanned < limit) ? "" : "...");
- Tcl_AppendPrintfToObj(post,
- " or \"%.*s%s(...)\" or ...",
- (scanned < limit) ? scanned : limit - 3,
- start, (scanned < limit) ? "" : "...");
- if (NotOperator(lastParsed)) {
- if ((lastStart[0] == '0')
- && ((lastStart[1] == 'o')
- || (lastStart[1] == 'O'))
- && (lastStart[2] >= '0')
- && (lastStart[2] <= '9')) {
- const char *end = lastStart + 2;
- Tcl_Obj* copy;
- while (isdigit(UCHAR(*end))) {
- end++;
- }
- copy = Tcl_NewStringObj(lastStart,
- end - lastStart);
- if (TclCheckBadOctal(NULL,
- Tcl_GetString(copy))) {
- Tcl_AppendToObj(post,
- "(invalid octal number?)", -1);
- }
- Tcl_DecrRefCount(copy);
+ Tcl_DecrRefCount(literal);
+ msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
+ (scanned < limit) ? scanned : limit - 3, start,
+ (scanned < limit) ? "" : "...");
+ post = Tcl_ObjPrintf(
+ "should be \"$%.*s%s\" or \"{%.*s%s}\"",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...");
+ Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...");
+ if (NotOperator(lastParsed)) {
+ errCode = "BADNUMBER";
+ if ((lastStart[0] == '0')
+ && ((lastStart[1] == 'o')
+ || (lastStart[1] == 'O'))
+ && (lastStart[2] >= '0')
+ && (lastStart[2] <= '9')) {
+ const char *end = lastStart + 2;
+ Tcl_Obj *copy;
+
+ while (isdigit(UCHAR(*end))) {
+ end++;
+ }
+ copy = Tcl_NewStringObj(lastStart, end-lastStart);
+ if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
+ Tcl_AppendToObj(post,
+ " (invalid octal number?)", -1);
+ errCode = "BADNUMBER";
+ subErrCode = "OCTAL";
}
- scanned = 0;
- insertMark = 1;
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+ Tcl_DecrRefCount(copy);
}
- goto error;
+ scanned = 0;
+ insertMark = 1;
+ parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+ } else {
+ errCode = "BAREWORD";
}
+ goto error;
}
break;
case PLUS:
case MINUS:
if (IsOperator(lastParsed)) {
-
/*
- * A "+" or "-" coming just after another operator
- * must be interpreted as a unary operator.
+ * A "+" or "-" coming just after another operator must be
+ * interpreted as a unary operator.
*/
lexeme |= UNARY;
@@ -792,8 +806,8 @@ ParseExpr(
/*
* Each LEAF results in either a literal getting appended to the
* litList, or a sequence of Tcl_Tokens representing a Tcl word
- * getting appended to the parsePtr->tokens. No OpNode is filled
- * for this lexeme.
+ * getting appended to the parsePtr->tokens. No OpNode is filled for
+ * this lexeme.
*/
case LEAF: {
@@ -809,12 +823,15 @@ ParseExpr(
if (NotOperator(lastParsed)) {
msg = Tcl_ObjPrintf("missing operator at %s", mark);
+ errCode = "MISSING";
if (lastStart[0] == '0') {
Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
start + scanned - lastStart);
+
if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
TclNewLiteralStringObj(post,
"looks like invalid octal number");
+ errCode = "BADNUMBER_OCTAL";
}
Tcl_DecrRefCount(copy);
}
@@ -831,7 +848,7 @@ ParseExpr(
switch (lexeme) {
case NUMBER:
- case BOOLEAN:
+ case BOOLEAN:
/*
* TODO: Consider using a dict or hash to collapse all
* duplicate literals into a single representative value.
@@ -839,28 +856,29 @@ ParseExpr(
* Pro: ~75% memory saving on expressions like
* {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost
* to "pointer" cost only)
- * Con: Cost of the dict store/retrieve on every literal
- * in every expression when expressions like the above
- * tend to be uncommon.
+ * Con: Cost of the dict store/retrieve on every literal in
+ * every expression when expressions like the above tend
+ * to be uncommon.
* The memory savings is temporary; Compiling to bytecode
* will collapse things as literals are registered
- * anyway, so the savings applies only to the time
- * between parsing and compiling. Possibly important
- * due to high-water mark nature of memory allocation.
+ * anyway, so the savings applies only to the time
+ * between parsing and compiling. Possibly important due
+ * to high-water mark nature of memory allocation.
*/
+
Tcl_ListObjAppendElement(NULL, litList, literal);
complete = lastParsed = OT_LITERAL;
start += scanned;
numBytes -= scanned;
continue;
-
+
default:
break;
}
/*
- * Remaining LEAF cases may involve filling Tcl_Tokens, so
- * make room for at least 2 more tokens.
+ * Remaining LEAF cases may involve filling Tcl_Tokens, so make
+ * room for at least 2 more tokens.
*/
TclGrowParseTokenArray(parsePtr, 2);
@@ -879,7 +897,7 @@ ParseExpr(
case BRACED:
code = Tcl_ParseBraces(NULL, start, numBytes,
- parsePtr, 1, &end);
+ parsePtr, 1, &end);
scanned = end - start;
break;
@@ -894,6 +912,7 @@ ParseExpr(
tokenPtr = parsePtr->tokenPtr + wordIndex + 1;
if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) {
TclNewLiteralStringObj(msg, "invalid character \"$\"");
+ errCode = "BADCHAR";
goto error;
}
scanned = tokenPtr->size;
@@ -901,7 +920,7 @@ ParseExpr(
case SCRIPT: {
Tcl_Parse *nestedPtr =
- (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
+ TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
tokenPtr->type = TCL_TOKEN_COMMAND;
@@ -911,7 +930,7 @@ ParseExpr(
end = start + numBytes;
start++;
while (1) {
- code = Tcl_ParseCommand(interp, start, (end - start), 1,
+ code = Tcl_ParseCommand(interp, start, end - start, 1,
nestedPtr);
if (code != TCL_OK) {
parsePtr->term = nestedPtr->term;
@@ -919,10 +938,10 @@ ParseExpr(
parsePtr->incomplete = nestedPtr->incomplete;
break;
}
- start = (nestedPtr->commandStart + nestedPtr->commandSize);
+ start = nestedPtr->commandStart + nestedPtr->commandSize;
Tcl_FreeParse(nestedPtr);
- if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']')
- && !(nestedPtr->incomplete)) {
+ if ((nestedPtr->term < end) && (nestedPtr->term[0] == ']')
+ && !nestedPtr->incomplete) {
break;
}
@@ -932,6 +951,7 @@ ParseExpr(
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->incomplete = 1;
code = TCL_ERROR;
+ errCode = "UNBALANCED";
break;
}
}
@@ -942,28 +962,29 @@ ParseExpr(
tokenPtr->size = scanned;
parsePtr->numTokens++;
break;
- }
+ } /* SCRIPT case */
}
if (code != TCL_OK) {
-
/*
- * Here we handle all the syntax errors generated by
- * the Tcl_Token generating parsing routines called in the
- * switch just above. If the value of parsePtr->incomplete
- * is 1, then the error was an unbalanced '[', '(', '{',
- * or '"' and parsePtr->term is pointing to that unbalanced
- * character. If the value of parsePtr->incomplete is 0,
- * then the error is one of lacking whitespace following a
- * quoted word, for example: expr {[an error {foo}bar]},
- * and parsePtr->term points to where the whitespace is
- * missing. We reset our values of start and scanned so that
- * when our error message is constructed, the location of
- * the syntax error is sure to appear in it, even if the
- * quoted expression is truncated.
+ * Here we handle all the syntax errors generated by the
+ * Tcl_Token generating parsing routines called in the switch
+ * just above. If the value of parsePtr->incomplete is 1, then
+ * the error was an unbalanced '[', '(', '{', or '"' and
+ * parsePtr->term is pointing to that unbalanced character. If
+ * the value of parsePtr->incomplete is 0, then the error is
+ * one of lacking whitespace following a quoted word, for
+ * example: expr {[an error {foo}bar]}, and parsePtr->term
+ * points to where the whitespace is missing. We reset our
+ * values of start and scanned so that when our error message
+ * is constructed, the location of the syntax error is sure to
+ * appear in it, even if the quoted expression is truncated.
*/
start = parsePtr->term;
scanned = parsePtr->incomplete;
+ if (parsePtr->incomplete) {
+ errCode = "UNBALANCED";
+ }
goto error;
}
@@ -971,20 +992,19 @@ ParseExpr(
tokenPtr->size = scanned;
tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1;
if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) {
-
/*
* When this expression is destined to be compiled, and a
* braced or quoted word within an expression is known at
- * compile time (no runtime substitutions in it), we can
- * store it as a literal rather than in its tokenized form.
- * This is an advantage since the compiled bytecode is going
- * to need the argument in Tcl_Obj form eventually, so it's
- * just as well to get there now. Another advantage is that
- * with this conversion, larger constant expressions might
- * be grown and optimized.
+ * compile time (no runtime substitutions in it), we can store
+ * it as a literal rather than in its tokenized form. This is
+ * an advantage since the compiled bytecode is going to need
+ * the argument in Tcl_Obj form eventually, so it's just as
+ * well to get there now. Another advantage is that with this
+ * conversion, larger constant expressions might be grown and
+ * optimized.
*
- * On the contrary, if the end goal of this parse is to
- * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's
+ * On the contrary, if the end goal of this parse is to fill a
+ * Tcl_Parse for a caller of Tcl_ParseExpr(), then it's
* wasteful to convert to a literal only to convert back again
* later.
*/
@@ -1014,6 +1034,7 @@ ParseExpr(
msg = Tcl_ObjPrintf("missing operator at %s", mark);
scanned = 0;
insertMark = 1;
+ errCode = "MISSING";
goto error;
}
@@ -1025,16 +1046,16 @@ ParseExpr(
/*
* A FUNCTION cannot be a constant expression, because Tcl allows
* functions to return variable results with the same arguments;
- * for example, rand(). Other unary operators can root a constant
+ * for example, rand(). Other unary operators can root a constant
* expression, so long as the argument is a constant expression.
*/
nodePtr->constant = (lexeme != FUNCTION);
/*
- * This unary operator is a new incomplete tree, so push it
- * onto our stack of incomplete trees. Also remember it as
- * the last lexeme we parsed.
+ * This unary operator is a new incomplete tree, so push it onto
+ * our stack of incomplete trees. Also remember it as the last
+ * lexeme we parsed.
*/
nodePtr->p.prev = incomplete;
@@ -1055,15 +1076,14 @@ ParseExpr(
if ((lexeme == CLOSE_PAREN)
&& (nodePtr[-1].lexeme == OPEN_PAREN)) {
if (nodePtr[-2].lexeme == FUNCTION) {
-
/*
* Normally, "()" is a syntax error, but as a special
* case accept it as an argument list for a function.
* Treat this as a special LEAF lexeme, and restart
- * the parsing loop with zero characters scanned.
- * We'll parse the ")" again the next time through,
- * but with the OT_EMPTY leaf as the subexpression
- * between the parens.
+ * the parsing loop with zero characters scanned. We
+ * will parse the ")" again the next time through, but
+ * with the OT_EMPTY leaf as the subexpression between
+ * the parens.
*/
scanned = 0;
@@ -1073,6 +1093,7 @@ ParseExpr(
msg = Tcl_ObjPrintf("empty subexpression at %s", mark);
scanned = 0;
insertMark = 1;
+ errCode = "EMPTY";
goto error;
}
@@ -1080,63 +1101,66 @@ ParseExpr(
if (nodePtr[-1].lexeme == OPEN_PAREN) {
TclNewLiteralStringObj(msg, "unbalanced open paren");
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
+ errCode = "UNBALANCED";
} else if (nodePtr[-1].lexeme == COMMA) {
msg = Tcl_ObjPrintf(
"missing function argument at %s", mark);
scanned = 0;
insertMark = 1;
+ errCode = "MISSING";
} else if (nodePtr[-1].lexeme == START) {
TclNewLiteralStringObj(msg, "empty expression");
+ errCode = "EMPTY";
}
- } else {
- if (lexeme == CLOSE_PAREN) {
- TclNewLiteralStringObj(msg, "unbalanced close paren");
- } else if ((lexeme == COMMA)
- && (nodePtr[-1].lexeme == OPEN_PAREN)
- && (nodePtr[-2].lexeme == FUNCTION)) {
- msg = Tcl_ObjPrintf(
- "missing function argument at %s", mark);
- scanned = 0;
- insertMark = 1;
- }
+ } else if (lexeme == CLOSE_PAREN) {
+ TclNewLiteralStringObj(msg, "unbalanced close paren");
+ errCode = "UNBALANCED";
+ } else if ((lexeme == COMMA)
+ && (nodePtr[-1].lexeme == OPEN_PAREN)
+ && (nodePtr[-2].lexeme == FUNCTION)) {
+ msg = Tcl_ObjPrintf("missing function argument at %s",
+ mark);
+ scanned = 0;
+ insertMark = 1;
+ errCode = "UNBALANCED";
}
if (msg == NULL) {
msg = Tcl_ObjPrintf("missing operand at %s", mark);
scanned = 0;
insertMark = 1;
+ errCode = "MISSING";
}
goto error;
}
/*
- * Here is where the tree comes together. At this point, we
- * have a stack of incomplete trees corresponding to
- * substrings that are incomplete expressions, followed by
- * a complete tree corresponding to a substring that is itself
- * a complete expression, followed by the binary operator we have
- * just parsed. The incomplete trees can each be completed by
- * adding a right operand.
+ * Here is where the tree comes together. At this point, we have a
+ * stack of incomplete trees corresponding to substrings that are
+ * incomplete expressions, followed by a complete tree
+ * corresponding to a substring that is itself a complete
+ * expression, followed by the binary operator we have just
+ * parsed. The incomplete trees can each be completed by adding a
+ * right operand.
*
* To illustrate with an example, when we parse the expression
* "1+2*3-4" and we reach this point having just parsed the "-"
* operator, we have these incomplete trees: START, "1+", and
- * "2*". Next we have the complete subexpression "3". Last is
- * the "-" we've just parsed.
+ * "2*". Next we have the complete subexpression "3". Last is the
+ * "-" we've just parsed.
*
- * The next step is to join our complete tree to an operator.
- * The choice is governed by the precedence and associativity
- * of the competing operators. If we connect it as the right
- * operand of our most recent incomplete tree, we get a new
- * complete tree, and we can repeat the process. The while
- * loop following repeats this until precedence indicates it
- * is time to join the complete tree as the left operand of
- * the just parsed binary operator.
+ * The next step is to join our complete tree to an operator. The
+ * choice is governed by the precedence and associativity of the
+ * competing operators. If we connect it as the right operand of
+ * our most recent incomplete tree, we get a new complete tree,
+ * and we can repeat the process. The while loop following repeats
+ * this until precedence indicates it is time to join the complete
+ * tree as the left operand of the just parsed binary operator.
*
- * Continuing the example, the first pass through the loop
- * will join "3" to "2*"; the next pass will join "2*3" to
- * "1+". Then we'll exit the loop and join "1+2*3" to "-".
- * When we return to parse another lexeme, our stack of
- * incomplete trees is START and "1+2*3-".
+ * Continuing the example, the first pass through the loop will
+ * join "3" to "2*"; the next pass will join "2*3" to "1+". Then
+ * we'll exit the loop and join "1+2*3" to "-". When we return to
+ * parse another lexeme, our stack of incomplete trees is START
+ * and "1+2*3-".
*/
while (1) {
@@ -1147,16 +1171,18 @@ ParseExpr(
}
if (incompletePtr->precedence == precedence) {
+ /*
+ * Right association rules for exponentiation.
+ */
- /* Right association rules for exponentiation. */
if (lexeme == EXPON) {
break;
}
/*
- * Special association rules for the conditional operators.
- * The "?" and ":" operators have equal precedence, but
- * must be linked up in sensible pairs.
+ * Special association rules for the conditional
+ * operators. The "?" and ":" operators have equal
+ * precedence, but must be linked up in sensible pairs.
*/
if ((incompletePtr->lexeme == QUESTION)
@@ -1170,13 +1196,16 @@ ParseExpr(
}
}
- /* Some special syntax checks... */
+ /*
+ * Some special syntax checks...
+ */
/* Parens must balance */
if ((incompletePtr->lexeme == OPEN_PAREN)
&& (lexeme != CLOSE_PAREN)) {
TclNewLiteralStringObj(msg, "unbalanced open paren");
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
+ errCode = "UNBALANCED";
goto error;
}
@@ -1184,10 +1213,10 @@ ParseExpr(
if ((incompletePtr->lexeme == QUESTION)
&& (NotOperator(complete)
|| (nodes[complete].lexeme != COLON))) {
- msg = Tcl_ObjPrintf(
- "missing operator \":\" at %s", mark);
+ msg = Tcl_ObjPrintf("missing operator \":\" at %s", mark);
scanned = 0;
insertMark = 1;
+ errCode = "MISSING";
goto error;
}
@@ -1198,6 +1227,7 @@ ParseExpr(
TclNewLiteralStringObj(msg,
"unexpected operator \":\" "
"without preceding \"?\"");
+ errCode = "SURPRISE";
goto error;
}
@@ -1217,9 +1247,9 @@ ParseExpr(
}
/*
- * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each
- * make up a single operator. Force them to agree whether they
- * have a constant expression.
+ * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations
+ * each make up a single operator. Force them to agree whether
+ * they have a constant expression.
*/
if ((incompletePtr->lexeme == QUESTION)
@@ -1228,7 +1258,6 @@ ParseExpr(
}
if (incompletePtr->lexeme == START) {
-
/*
* Completing the START tree indicates we're done.
* Transfer the parse tree to the caller and return.
@@ -1240,8 +1269,8 @@ ParseExpr(
/*
* With a right operand attached, last incomplete tree has
- * become the complete tree. Pop it from the incomplete
- * tree stack.
+ * become the complete tree. Pop it from the incomplete tree
+ * stack.
*/
complete = incomplete;
@@ -1253,12 +1282,15 @@ ParseExpr(
}
}
- /* More syntax checks... */
+ /*
+ * More syntax checks...
+ */
/* Parens must balance. */
if (lexeme == CLOSE_PAREN) {
if (incompletePtr->lexeme != OPEN_PAREN) {
TclNewLiteralStringObj(msg, "unbalanced close paren");
+ errCode = "UNBALANCED";
goto error;
}
}
@@ -1269,6 +1301,7 @@ ParseExpr(
|| (incompletePtr[-1].lexeme != FUNCTION)) {
TclNewLiteralStringObj(msg,
"unexpected \",\" outside function argument list");
+ errCode = "SURPRISE";
goto error;
}
}
@@ -1277,25 +1310,32 @@ ParseExpr(
if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) {
TclNewLiteralStringObj(msg,
"unexpected operator \":\" without preceding \"?\"");
+ errCode = "SURPRISE";
goto error;
}
- /* Create no node for a CLOSE_PAREN lexeme. */
+ /*
+ * Create no node for a CLOSE_PAREN lexeme.
+ */
+
if (lexeme == CLOSE_PAREN) {
break;
}
- /* Link complete tree as left operand of new node. */
+ /*
+ * Link complete tree as left operand of new node.
+ */
+
nodePtr->lexeme = lexeme;
nodePtr->precedence = precedence;
nodePtr->mark = MARK_LEFT;
nodePtr->left = complete;
- /*
+ /*
* The COMMA operator cannot be optimized, since the function
- * needs all of its arguments, and optimization would reduce
- * the number. Other binary operators root constant expressions
- * when both arguments are constant expressions.
+ * needs all of its arguments, and optimization would reduce the
+ * number. Other binary operators root constant expressions when
+ * both arguments are constant expressions.
*/
nodePtr->constant = (lexeme != COMMA);
@@ -1310,9 +1350,9 @@ ParseExpr(
}
/*
- * With a left operand attached and a right operand missing,
- * the just-parsed binary operator is root of a new incomplete
- * tree. Push it onto the stack of incomplete trees.
+ * With a left operand attached and a right operand missing, the
+ * just-parsed binary operator is root of a new incomplete tree.
+ * Push it onto the stack of incomplete trees.
*/
nodePtr->p.prev = incomplete;
@@ -1327,34 +1367,36 @@ ParseExpr(
numBytes -= scanned;
} /* main parsing loop */
- error:
-
/*
- * We only get here if there's been an error.
- * Any errors that didn't get a suitable parsePtr->errorType,
- * get recorded as syntax errors.
+ * We only get here if there's been an error. Any errors that didn't get a
+ * suitable parsePtr->errorType, get recorded as syntax errors.
*/
+ error:
if (parsePtr->errorType == TCL_PARSE_SUCCESS) {
parsePtr->errorType = TCL_PARSE_SYNTAX;
}
- /* Free any partial parse tree we've built. */
+ /*
+ * Free any partial parse tree we've built.
+ */
+
if (nodes != NULL) {
- ckfree((char*) nodes);
+ ckfree(nodes);
}
if (interp == NULL) {
+ /*
+ * Nowhere to report an error message, so just free it.
+ */
- /* Nowhere to report an error message, so just free it */
if (msg) {
Tcl_DecrRefCount(msg);
}
} else {
-
/*
- * Construct the complete error message. Start with the simple
- * error message, pulled from the interp result if necessary...
+ * Construct the complete error message. Start with the simple error
+ * message, pulled from the interp result if necessary...
*/
if (msg == NULL) {
@@ -1379,7 +1421,10 @@ ParseExpr(
start + scanned,
(start + scanned + limit > parsePtr->end) ? "" : "...");
- /* Next, append any postscript message. */
+ /*
+ * Next, append any postscript message.
+ */
+
if (post != NULL) {
Tcl_AppendToObj(msg, ";\n", -1);
Tcl_AppendObjToObj(msg, post);
@@ -1387,12 +1432,19 @@ ParseExpr(
}
Tcl_SetObjResult(interp, msg);
- /* Finally, place context information in the errorInfo. */
+ /*
+ * Finally, place context information in the errorInfo.
+ */
+
numBytes = parsePtr->end - parsePtr->string;
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (parsing expression \"%.*s%s\")",
(numBytes < limit) ? numBytes : limit - 3,
parsePtr->string, (numBytes < limit) ? "" : "..."));
+ if (errCode) {
+ Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
+ subErrCode, NULL);
+ }
}
return TCL_ERROR;
@@ -1406,10 +1458,10 @@ ParseExpr(
* Given a string, the numBytes bytes starting at start, and an OpNode
* tree and Tcl_Token array created by passing that same string to
* ParseExpr(), this function writes into *parsePtr the sequence of
- * Tcl_Tokens needed so to satisfy the historical interface provided
- * by Tcl_ParseExpr(). Note that this routine exists only for the sake
- * of the public Tcl_ParseExpr() routine. It is not used by Tcl itself
- * at all.
+ * Tcl_Tokens needed so to satisfy the historical interface provided by
+ * Tcl_ParseExpr(). Note that this routine exists only for the sake of
+ * the public Tcl_ParseExpr() routine. It is not used by Tcl itself at
+ * all.
*
* Results:
* None.
@@ -1445,7 +1497,10 @@ ConvertTreeToTokens(
nodePtr->mark++;
- /* Handle next child node or leaf */
+ /*
+ * Handle next child node or leaf.
+ */
+
switch (next) {
case OT_EMPTY:
@@ -1456,10 +1511,13 @@ ConvertTreeToTokens(
/* Skip any white space that comes before the literal */
scanned = TclParseAllWhiteSpace(start, numBytes);
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
- /* Reparse the literal to get pointers into source string */
+ /*
+ * Reparse the literal to get pointers into source string.
+ */
+
scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
TclGrowParseTokenArray(parsePtr, 2);
@@ -1474,32 +1532,30 @@ ConvertTreeToTokens(
subExprTokenPtr[1].numComponents = 0;
parsePtr->numTokens += 2;
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
break;
case OT_TOKENS: {
-
/*
- * tokenPtr points to a token sequence that came from parsing
- * a Tcl word. A Tcl word is made up of a sequence of one or
- * more elements. When the word is only a single element, it's
- * been the historical practice to replace the TCL_TOKEN_WORD
- * token directly with a TCL_TOKEN_SUB_EXPR token. However,
- * when the word has multiple elements, a TCL_TOKEN_WORD token
- * is kept as a grouping device so that TCL_TOKEN_SUB_EXPR
- * always has only one element. Wise or not, these are the
- * rules the Tcl expr parser has followed, and for the sake
- * of those few callers of Tcl_ParseExpr() we do not change
- * them now. Internally, we can do better.
+ * tokenPtr points to a token sequence that came from parsing a
+ * Tcl word. A Tcl word is made up of a sequence of one or more
+ * elements. When the word is only a single element, it's been the
+ * historical practice to replace the TCL_TOKEN_WORD token
+ * directly with a TCL_TOKEN_SUB_EXPR token. However, when the
+ * word has multiple elements, a TCL_TOKEN_WORD token is kept as a
+ * grouping device so that TCL_TOKEN_SUB_EXPR always has only one
+ * element. Wise or not, these are the rules the Tcl expr parser
+ * has followed, and for the sake of those few callers of
+ * Tcl_ParseExpr() we do not change them now. Internally, we can
+ * do better.
*/
-
+
int toCopy = tokenPtr->numComponents + 1;
if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) {
-
/*
- * Single element word. Copy tokens and convert the leading
+ * Single element word. Copy tokens and convert the leading
* token to TCL_TOKEN_SUB_EXPR.
*/
@@ -1510,11 +1566,10 @@ ConvertTreeToTokens(
subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
parsePtr->numTokens += toCopy;
} else {
-
- /*
- * Multiple element word. Create a TCL_TOKEN_SUB_EXPR
- * token to lead, with fields initialized from the leading
- * token, then copy entire set of word tokens.
+ /*
+ * Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to
+ * lead, with fields initialized from the leading token, then
+ * copy entire set of word tokens.
*/
TclGrowParseTokenArray(parsePtr, toCopy+1);
@@ -1529,7 +1584,7 @@ ConvertTreeToTokens(
}
scanned = tokenPtr->start + tokenPtr->size - start;
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
tokenPtr += toCopy;
break;
@@ -1540,18 +1595,24 @@ ConvertTreeToTokens(
/* Advance to the child node, which is an operator. */
nodePtr = nodes + next;
- /* Skip any white space that comes before the subexpression */
+ /*
+ * Skip any white space that comes before the subexpression.
+ */
+
scanned = TclParseAllWhiteSpace(start, numBytes);
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
- /* Generate tokens for the operator / subexpression... */
+ /*
+ * Generate tokens for the operator / subexpression...
+ */
+
switch (nodePtr->lexeme) {
case OPEN_PAREN:
case COMMA:
case COLON:
- /*
+ /*
* Historical practice has been to have no Tcl_Tokens for
* these operators.
*/
@@ -1562,16 +1623,16 @@ ConvertTreeToTokens(
/*
* Remember the index of the last subexpression we were
- * working on -- that of our parent. We'll stack it later.
+ * working on -- that of our parent. We'll stack it later.
*/
parentIdx = subExprTokenIdx;
/*
* Verify space for the two leading Tcl_Tokens representing
- * the subexpression rooted by this operator. The first
- * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second
- * of type TCL_TOKEN_OPERATOR.
+ * the subexpression rooted by this operator. The first
+ * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second of
+ * type TCL_TOKEN_OPERATOR.
*/
TclGrowParseTokenArray(parsePtr, 2);
@@ -1590,7 +1651,7 @@ ConvertTreeToTokens(
/*
* Eventually, we know that the numComponents field of the
- * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means
+ * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means
* we can make other use of this field for now to track the
* stack of subexpressions we have pending.
*/
@@ -1614,7 +1675,7 @@ ConvertTreeToTokens(
/* Skip any white space that comes before the operator */
scanned = TclParseAllWhiteSpace(start, numBytes);
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
/*
@@ -1645,7 +1706,7 @@ ConvertTreeToTokens(
break;
}
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
break;
@@ -1666,10 +1727,10 @@ ConvertTreeToTokens(
/* Skip past matching close paren. */
scanned = TclParseAllWhiteSpace(start, numBytes);
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
- start +=scanned;
+ start += scanned;
numBytes -= scanned;
break;
@@ -1678,7 +1739,7 @@ ConvertTreeToTokens(
/*
* Before we leave this node/operator/subexpression for the
* last time, finish up its tokens....
- *
+ *
* Our current position scanning the string is where the
* substring for the subexpression ends.
*/
@@ -1688,7 +1749,7 @@ ConvertTreeToTokens(
/*
* All the Tcl_Tokens allocated and filled belong to
- * this subexpresion. The first token is the leading
+ * this subexpresion. The first token is the leading
* TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
* are its components.
*/
@@ -1709,7 +1770,10 @@ ConvertTreeToTokens(
}
}
- /* Since we're returning to parent, skip child handling code. */
+ /*
+ * Since we're returning to parent, skip child handling code.
+ */
+
nodePtr = nodes + nodePtr->p.parent;
goto router;
}
@@ -1754,19 +1818,18 @@ Tcl_ParseExpr(
* information in the structure is ignored. */
{
int code;
- OpNode *opTree = NULL; /* Will point to the tree of operators */
- Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */
- Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/
- Tcl_Parse *exprParsePtr =
- (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
- /* Holds the Tcl_Tokens of substitutions */
+ OpNode *opTree = NULL; /* Will point to the tree of operators. */
+ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */
+ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */
+ Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ /* Holds the Tcl_Tokens of substitutions. */
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
}
- code = ParseExpr(interp, start, numBytes, &opTree, litList,
- funcList, exprParsePtr, 1 /* parseOnly */);
+ code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
+ exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
@@ -1781,7 +1844,7 @@ Tcl_ParseExpr(
Tcl_FreeParse(exprParsePtr);
TclStackFree(interp, exprParsePtr);
- ckfree((char *) opTree);
+ ckfree(opTree);
return code;
}
@@ -1821,7 +1884,7 @@ ParseLexeme(
*lexemePtr = END;
return 0;
}
- byte = (unsigned char)(*start);
+ byte = UCHAR(*start);
if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) {
*lexemePtr = Lexeme[byte];
return 1;
@@ -1898,11 +1961,10 @@ ParseLexeme(
case 'i':
if ((numBytes > 1) && (start[1] == 'n')
&& ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
-
/*
- * Must make this check so we can tell the difference between
- * the "in" operator and the "int" function name and the
- * "infinity" numeric value.
+ * Must make this check so we can tell the difference between the
+ * "in" operator and the "int" function name and the "infinity"
+ * numeric value.
*/
*lexemePtr = IN_LIST;
@@ -1948,6 +2010,7 @@ ParseLexeme(
scanned = Tcl_UtfToUniChar(start, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
+
memcpy(utfBytes, start, (size_t) numBytes);
utfBytes[numBytes] = '\0';
scanned = Tcl_UtfToUniChar(utfBytes, &ch);
@@ -1965,6 +2028,7 @@ ParseLexeme(
scanned = Tcl_UtfToUniChar(end, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
+
memcpy(utfBytes, end, (size_t) numBytes);
utfBytes[numBytes] = '\0';
scanned = Tcl_UtfToUniChar(utfBytes, &ch);
@@ -1986,7 +2050,7 @@ ParseLexeme(
* TclCompileExpr --
*
* This procedure compiles a string containing a Tcl expression into Tcl
- * bytecodes.
+ * bytecodes.
*
* Results:
* None.
@@ -2003,21 +2067,22 @@ TclCompileExpr(
const char *script, /* The source script to compile. */
int numBytes, /* Number of bytes in script. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int optimize) /* 0 for one-off expressions */
+ int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/
- Tcl_Parse *parsePtr =
- (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code = ParseExpr(interp, script, numBytes, &opTree, litList,
funcList, parsePtr, 0 /* parseOnly */);
if (code == TCL_OK) {
+ /*
+ * Valid parse; compile the tree.
+ */
- /* Valid parse; compile the tree. */
int objc;
Tcl_Obj *const *litObjv;
Tcl_Obj **funcObjv;
@@ -2038,7 +2103,7 @@ TclCompileExpr(
TclStackFree(interp, parsePtr);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
- ckfree((char *) opTree);
+ ckfree(opTree);
}
/*
@@ -2070,6 +2135,7 @@ ExecConstantExprTree(
ByteCode *byteCodePtr;
int code;
Tcl_Obj *byteCodeObj = Tcl_NewObj();
+ NRE_callback *rootPtr = TOP_CB(interp);
/*
* Note we are compiling an expression with literal arguments. This means
@@ -2077,7 +2143,7 @@ ExecConstantExprTree(
* bytecode, so there's no need to tend to TIP 280 issues.
*/
- envPtr = (CompileEnv *) TclStackAlloc(interp, sizeof(CompileEnv));
+ envPtr = TclStackAlloc(interp, sizeof(CompileEnv));
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
@@ -2086,8 +2152,9 @@ ExecConstantExprTree(
TclInitByteCodeObj(byteCodeObj, envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr;
- code = TclExecuteByteCode(interp, byteCodePtr);
+ byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
+ TclNRExecuteByteCode(interp, byteCodePtr);
+ code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
Tcl_DecrRefCount(byteCodeObj);
return code;
}
@@ -2096,20 +2163,20 @@ ExecConstantExprTree(
*----------------------------------------------------------------------
*
* CompileExprTree --
- * Compiles and writes to envPtr instructions for the subexpression
- * tree at index in the nodes array. (*litObjvPtr) must point to the
- * proper location in a corresponding literals list. Likewise, when
- * non-NULL, funcObjv and tokenPtr must point into matching arrays of
- * function names and Tcl_Token's derived from earlier call to
- * ParseExpr(). When optimize is true, any constant subexpressions
- * will be precomputed.
+ *
+ * Compiles and writes to envPtr instructions for the subexpression tree
+ * at index in the nodes array. (*litObjvPtr) must point to the proper
+ * location in a corresponding literals list. Likewise, when non-NULL,
+ * funcObjv and tokenPtr must point into matching arrays of function
+ * names and Tcl_Token's derived from earlier call to ParseExpr(). When
+ * optimize is true, any constant subexpressions will be precomputed.
*
* Results:
* None.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
- * Consumes subtree of nodes rooted at index. Advances the pointer
+ * Consumes subtree of nodes rooted at index. Advances the pointer
* *litObjvPtr.
*
*----------------------------------------------------------------------
@@ -2141,10 +2208,10 @@ CompileExprTree(
switch (nodePtr->lexeme) {
case QUESTION:
- newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
- newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
jumpPtr->depth = envPtr->currStackDepth;
@@ -2152,13 +2219,13 @@ CompileExprTree(
break;
case AND:
case OR:
- newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
- newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
- newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
jumpPtr->depth = envPtr->currStackDepth;
@@ -2178,16 +2245,16 @@ CompileExprTree(
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
- TclEmitPush(TclRegisterNewNSLiteral(envPtr,
+ TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName)), envPtr);
Tcl_DStringFree(&cmdName);
/*
* Start a count of the number of words in this function
- * command invocation. In case there's already a count
- * in progress (nested functions), save it in our unused
- * "left" field for restoring later.
+ * command invocation. In case there's already a count in
+ * progress (nested functions), save it in our unused "left"
+ * field for restoring later.
*/
nodePtr->left = numWords;
@@ -2198,6 +2265,7 @@ CompileExprTree(
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
break;
case COLON:
+ CLANG_ASSERT(jumpPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&(jumpPtr->next->jump));
envPtr->currStackDepth = jumpPtr->depth;
@@ -2225,28 +2293,33 @@ CompileExprTree(
/* do nothing */
break;
case FUNCTION:
-
/*
- * Use the numWords count we've kept to invoke the
- * function command with the correct number of arguments.
+ * Use the numWords count we've kept to invoke the function
+ * command with the correct number of arguments.
*/
-
+
if (numWords < 255) {
TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
} else {
TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
}
- /* Restore any saved numWords value. */
+ /*
+ * Restore any saved numWords value.
+ */
+
numWords = nodePtr->left;
convert = 1;
break;
case COMMA:
+ /*
+ * Each comma implies another function argument.
+ */
- /* Each comma implies another function argument. */
numWords++;
break;
case COLON:
+ CLANG_ASSERT(jumpPtr);
if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump),
(envPtr->codeNext - envPtr->codeStart)
- jumpPtr->next->jump.codeOffset, 127)) {
@@ -2265,6 +2338,7 @@ CompileExprTree(
break;
case AND:
case OR:
+ CLANG_ASSERT(jumpPtr);
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
? TCL_FALSE_JUMP : TCL_TRUE_JUMP,
&(jumpPtr->next->jump));
@@ -2334,10 +2408,10 @@ CompileExprTree(
*
* However, the design of the "global" and "local"
* LiteralTable does not permit the value of lePtr->objPtr
- * to change. So rather than replace lePtr->objPtr, we
- * do surgery to transfer our desired intrep into it.
- *
+ * to change. So rather than replace lePtr->objPtr, we do
+ * surgery to transfer our desired intrep into it.
*/
+
objPtr->typePtr = literal->typePtr;
objPtr->internalRep = literal->internalRep;
literal->typePtr = NULL;
@@ -2345,13 +2419,14 @@ CompileExprTree(
TclEmitPush(index, envPtr);
} else {
/*
- * When optimize==0, we know the expression is a one-off
- * and there's nothing to be gained from sharing literals
- * when they won't live long, and the copies we have already
- * have an appropriate intrep. In this case, skip literal
+ * When optimize==0, we know the expression is a one-off and
+ * there's nothing to be gained from sharing literals when
+ * they won't live long, and the copies we have already have
+ * an appropriate intrep. In this case, skip literal
* registration that would enable sharing, and use the routine
* that preserves intreps.
*/
+
TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr);
}
(*litObjvPtr)++;
@@ -2365,6 +2440,7 @@ CompileExprTree(
default:
if (optimize && nodes[next].constant) {
Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK);
+
if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
== TCL_OK) {
TclEmitPush(TclAddLiteralObj(envPtr,
@@ -2394,7 +2470,7 @@ CompileExprTree(
* A standard Tcl return code and result left in interp.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2406,7 +2482,7 @@ TclSingleOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
+ TclOpCmdClientData *occdPtr = clientData;
unsigned char lexeme;
OpNode nodes[2];
Tcl_Obj *const *litObjv = objv + 1;
@@ -2437,16 +2513,17 @@ TclSingleOpCmd(
*----------------------------------------------------------------------
*
* TclSortingOpCmd --
- * Implements the commands: <, <=, >, >=, ==, eq
- * in the ::tcl::mathop namespace. These commands are defined for
+ * Implements the commands:
+ * <, <=, >, >=, ==, eq
+ * in the ::tcl::mathop namespace. These commands are defined for
* arbitrary number of arguments by computing the AND of the base
- * operator applied to all neighbor argument pairs.
+ * operator applied to all neighbor argument pairs.
*
* Results:
* A standard Tcl return code and result left in interp.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2463,11 +2540,10 @@ TclSortingOpCmd(
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
- TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
- Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp,
- 2*(objc-2)*sizeof(Tcl_Obj *));
- OpNode *nodes = (OpNode *) TclStackAlloc(interp,
- 2*(objc-2)*sizeof(OpNode));
+ TclOpCmdClientData *occdPtr = clientData;
+ Tcl_Obj **litObjv = TclStackAlloc(interp,
+ 2 * (objc-2) * sizeof(Tcl_Obj *));
+ OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
unsigned char lexeme;
int i, lastAnd = 1;
Tcl_Obj *const *litObjPtrPtr = litObjv;
@@ -2518,16 +2594,16 @@ TclSortingOpCmd(
*
* TclVariadicOpCmd --
* Implements the commands: +, *, &, |, ^, **
- * in the ::tcl::mathop namespace. These commands are defined for
+ * in the ::tcl::mathop namespace. These commands are defined for
* arbitrary number of arguments by repeatedly applying the base
- * operator with suitable associative rules. When fewer than two
+ * operator with suitable associative rules. When fewer than two
* arguments are provided, suitable identity values are returned.
*
* Results:
* A standard Tcl return code and result left in interp.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2539,7 +2615,7 @@ TclVariadicOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
+ TclOpCmdClientData *occdPtr = clientData;
unsigned char lexeme;
int code;
@@ -2594,14 +2670,13 @@ TclVariadicOpCmd(
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
- OpNode *nodes = (OpNode *) TclStackAlloc(interp,
- (objc-1)*sizeof(OpNode));
+ OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
int i, lastOp = OT_LITERAL;
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
if (lexeme == EXPON) {
- for (i=objc-2; i>0; i-- ) {
+ for (i=objc-2; i>0; i--) {
nodes[i].lexeme = lexeme;
nodes[i].mark = MARK_LEFT;
nodes[i].left = OT_LITERAL;
@@ -2612,7 +2687,7 @@ TclVariadicOpCmd(
lastOp = i;
}
} else {
- for (i=1; i<objc-1; i++ ) {
+ for (i=1; i<objc-1; i++) {
nodes[i].lexeme = lexeme;
nodes[i].mark = MARK_LEFT;
nodes[i].left = lastOp;
@@ -2629,7 +2704,6 @@ TclVariadicOpCmd(
code = ExecConstantExprTree(interp, nodes, 0, &litObjv);
TclStackFree(interp, nodes);
-
return code;
}
}
@@ -2639,16 +2713,16 @@ TclVariadicOpCmd(
*
* TclNoIdentOpCmd --
* Implements the commands: -, /
- * in the ::tcl::mathop namespace. These commands are defined for
- * arbitrary non-zero number of arguments by repeatedly applying
- * the base operator with suitable associative rules. When no
- * arguments are provided, an error is raised.
+ * in the ::tcl::mathop namespace. These commands are defined for
+ * arbitrary non-zero number of arguments by repeatedly applying the base
+ * operator with suitable associative rules. When no arguments are
+ * provided, an error is raised.
*
* Results:
* A standard Tcl return code and result left in interp.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2660,7 +2734,8 @@ TclNoIdentOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
+ TclOpCmdClientData *occdPtr = clientData;
+
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
return TCL_ERROR;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2d8d58c..2194ae1 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -50,7 +50,7 @@ static int traceInitialized = 0;
* existence of a procedure call frame to distinguish these.
*/
-InstructionDesc tclInstructionTable[] = {
+InstructionDesc const tclInstructionTable[] = {
/* Name Bytes stackEffect #Opnds Operand types */
{"done", 1, -1, 0, {OPERAND_NONE}},
/* Finish ByteCode execution and return stktop (top stack item) */
@@ -154,11 +154,11 @@ InstructionDesc tclInstructionTable[] = {
{"lt", 1, -1, 0, {OPERAND_NONE}},
/* Less: push (stknext < stktop) */
{"gt", 1, -1, 0, {OPERAND_NONE}},
- /* Greater: push (stknext || stktop) */
+ /* Greater: push (stknext > stktop) */
{"le", 1, -1, 0, {OPERAND_NONE}},
- /* Less or equal: push (stknext || stktop) */
+ /* Less or equal: push (stknext <= stktop) */
{"ge", 1, -1, 0, {OPERAND_NONE}},
- /* Greater or equal: push (stknext || stktop) */
+ /* Greater or equal: push (stknext >= stktop) */
{"lshift", 1, -1, 0, {OPERAND_NONE}},
/* Left shift: push (stknext << stktop) */
{"rshift", 1, -1, 0, {OPERAND_NONE}},
@@ -341,21 +341,23 @@ InstructionDesc tclInstructionTable[] = {
* Stack: ... key valueToAppend => ... newDict */
{"dictFirst", 5, +2, 1, {OPERAND_LVT4}},
/* Begin iterating over the dictionary, using the local scalar
- * indicated by op4 to hold the iterator state. If doneBool is true,
- * dictDone *must* be called later on.
+ * indicated by op4 to hold the iterator state. The local scalar
+ * should not refer to a named variable as the value is not wholly
+ * managed correctly.
* Stack: ... dict => ... value key doneBool */
{"dictNext", 5, +3, 1, {OPERAND_LVT4}},
/* Get the next iteration from the iterator in op4's local scalar.
* Stack: ... => ... value key doneBool */
{"dictDone", 5, 0, 1, {OPERAND_LVT4}},
- /* Terminate the iterator in op4's local scalar. */
+ /* Terminate the iterator in op4's local scalar. Use unsetScalar
+ * instead (with 0 for flags). */
{"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}},
/* Create the variables (described in the aux data referred to by the
* second immediate argument) to mirror the state of the dictionary in
* the variable referred to by the first immediate argument. The list
- * of keys (popped from the stack) must be the same length as the list
- * of variables.
- * Stack: ... keyList => ... */
+ * of keys (top of the stack, not poppsed) must be the same length as
+ * the list of variables.
+ * Stack: ... keyList => ... keyList */
{"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}},
/* Reflect the state of local variables (described in the aux data
* referred to by the second immediate argument) back to the state of
@@ -363,7 +365,7 @@ InstructionDesc tclInstructionTable[] = {
* argument. The list of keys (popped from the stack) must be the same
* length as the list of variables.
* Stack: ... keyList => ... */
- {"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
+ {"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
/* Jump according to the jump-table (in AuxData as indicated by the
* operand) and the argument popped from the list. Always executes the
* next instruction if no match against the table's entries was found.
@@ -371,15 +373,15 @@ InstructionDesc tclInstructionTable[] = {
* Note that the jump table contains offsets relative to the PC when
* it points to this instruction; the code is relocatable. */
{"upvar", 5, 0, 1, {OPERAND_LVT4}},
- /* finds level and otherName in stack, links to local variable at
- * index op1. Leaves the level on stack. */
+ /* finds level and otherName in stack, links to local variable at
+ * index op1. Leaves the level on stack. */
{"nsupvar", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
- * index op1. Leaves the namespace on stack. */
+ /* finds namespace and otherName in stack, links to local variable at
+ * index op1. Leaves the namespace on stack. */
{"variable", 5, 0, 1, {OPERAND_LVT4}},
- /* 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}},
+ /* 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. */
{"reverse", 5, 0, 1, {OPERAND_UINT4}},
/* Reverse the order of the arg elements at the top of stack */
@@ -397,13 +399,37 @@ InstructionDesc tclInstructionTable[] = {
* stknext */
{"existStk", 1, 0, 0, {OPERAND_NONE}},
/* Test if general variable exists; unparsed variable name is stktop*/
- {0}
-};
+ {"nop", 1, 0, 0, {OPERAND_NONE}},
+ /* Do nothing */
+ {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}},
+ /* Jump to next instruction based on the return code on top of stack
+ * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7;
+ * Other non-OK: +9
+ */
+
+ {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}},
+ /* Make scalar variable at index op2 in call frame cease to exist;
+ * op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}},
+ /* Make array element cease to exist; array at slot op2, element is
+ * stktop; op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}},
+ /* Make array element cease to exist; element is stktop, array name is
+ * stknext; op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetStk", 2, -1, 1, {OPERAND_UINT1}},
+ /* Make general variable cease to exist; unparsed variable name is
+ * stktop; op1 is 1 for errors on problems, 0 otherwise */
+
+ {NULL, 0, 0, 0, {OPERAND_NONE}}
+};
+
/*
* Prototypes for procedures defined later in this file:
*/
+static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags);
static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr,
@@ -413,6 +439,7 @@ static void EnterCmdExtentData(CompileEnv *envPtr,
static void EnterCmdStartData(CompileEnv *envPtr,
int cmdNumber, int srcOffset, int codeOffset);
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
+static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
@@ -420,30 +447,58 @@ static void RecordByteCodeStats(ByteCode *codePtr);
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static int FormatInstruction(ByteCode *codePtr,
- unsigned char *pc, Tcl_Obj *bufferObj);
+ const unsigned char *pc, Tcl_Obj *bufferObj);
static void PrintSourceToObj(Tcl_Obj *appendObj,
const char *stringPtr, int maxChars);
+static void UpdateStringOfInstName(Tcl_Obj *objPtr);
+
/*
* TIP #280: Helper for building the per-word line information of all compiled
* commands.
*/
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);
+ int numWords, int line, int *clNext, int **lines,
+ CompileEnv *envPtr);
/*
* The structure below defines the bytecode Tcl object type by means of
* procedures that can be invoked by generic object code.
*/
-Tcl_ObjType tclByteCodeType = {
+const Tcl_ObjType tclByteCodeType = {
"bytecode", /* name */
FreeByteCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetByteCodeFromAny /* setFromAnyProc */
};
+
+/*
+ * The structure below defines a bytecode Tcl object type to hold the
+ * compiled bytecode for the [subst]itution of Tcl values.
+ */
+
+static const Tcl_ObjType substCodeType = {
+ "substcode", /* name */
+ FreeSubstCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */
+ NULL, /* updateStringProc */
+ NULL, /* setFromAnyProc */
+};
+
+/*
+ * The structure below defines an instruction name Tcl object to allow
+ * reporting of inner contexts in errorstack without string allocation.
+ */
+
+static const Tcl_ObjType tclInstNameType = {
+ "instname", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfInstName, /* updateStringProc */
+ NULL, /* setFromAnyProc */
+};
/*
*----------------------------------------------------------------------
@@ -482,12 +537,12 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- register AuxData *auxDataPtr;
+ register const AuxData *auxDataPtr;
LiteralEntry *entryPtr;
register int i;
int length, result = TCL_OK;
const char *stringPtr;
- ContLineLoc* clLocPtr;
+ ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
@@ -509,6 +564,7 @@ TclSetByteCodeFromAny(
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
+
/*
* Now we check if we have data about invisible continuation lines for the
* script, and make it available to the compile environment, if so.
@@ -516,16 +572,16 @@ TclSetByteCodeFromAny(
* It is not clear if the script Tcl_Obj* can be free'd while the compiler
* is using it, leading to the release of the associated ContLineLoc
* structure as well. To ensure that the latter doesn't happen we set a
- * lock on it. We release this lock in the function TclFreeCompileEnv (),
+ * lock on it. We release this lock in the function TclFreeCompileEnv(),
* found in this file. The "lineCLPtr" hashtable is managed in the file
* "tclObj.c".
*/
- clLocPtr = TclContinuationsGet (objPtr);
+ clLocPtr = TclContinuationsGet(objPtr);
if (clLocPtr) {
- compEnv.clLoc = clLocPtr;
+ compEnv.clLoc = clLocPtr;
compEnv.clNext = &compEnv.clLoc->loc[0];
- Tcl_Preserve (compEnv.clLoc);
+ Tcl_Preserve(compEnv.clLoc);
}
TclCompileScript(interp, stringPtr, length, &compEnv);
@@ -541,7 +597,7 @@ TclSetByteCodeFromAny(
*/
if (hookProc) {
- result = (*hookProc)(interp, &compEnv, clientData);
+ result = hookProc(interp, &compEnv, clientData);
}
/*
@@ -620,7 +676,7 @@ SetByteCodeFromAny(
if (interp == NULL) {
return TCL_ERROR;
}
- (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL);
+ TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
return TCL_OK;
}
@@ -675,15 +731,14 @@ static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = (ByteCode *)
- objPtr->internalRep.otherValuePtr;
+ register ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
- objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
}
/*
@@ -715,7 +770,7 @@ TclCleanupByteCode(
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
register Tcl_Obj **objArrayPtr, *objPtr;
- register AuxData *auxDataPtr;
+ register const AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
@@ -724,7 +779,7 @@ TclCleanupByteCode(
Tcl_Time destroyTime;
int lifetimeSec, lifetimeMicroSec, log2;
- statsPtr = &((Interp *) interp)->stats;
+ statsPtr = &iPtr->stats;
statsPtr->numByteCodesFreed++;
statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
@@ -806,7 +861,7 @@ TclCleanupByteCode(
auxDataPtr = codePtr->auxDataArrayPtr;
for (i = 0; i < numAuxDataItems; i++) {
if (auxDataPtr->type->freeProc != NULL) {
- (auxDataPtr->type->freeProc)(auxDataPtr->clientData);
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
@@ -822,24 +877,24 @@ TclCleanupByteCode(
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
(char *) codePtr);
+
if (hePtr) {
ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
- 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);
+ ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
- ckfree((char *) eclPtr->loc);
+ ckfree(eclPtr->loc);
}
- Tcl_DeleteHashTable (&eclPtr->litInfo);
+ Tcl_DeleteHashTable(&eclPtr->litInfo);
- ckfree((char *) eclPtr);
+ ckfree(eclPtr);
Tcl_DeleteHashEntry(hePtr);
}
}
@@ -849,7 +904,177 @@ TclCleanupByteCode(
}
TclHandleRelease(codePtr->interpHandle);
- ckfree((char *) codePtr);
+ ckfree(codePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstObj --
+ *
+ * This function performs the substitutions specified on the given string
+ * as described in the user documentation for the "subst" Tcl command.
+ *
+ * Results:
+ * A Tcl_Obj* containing the substituted string, or NULL to indicate that
+ * an error occurred.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_SubstObj(
+ Tcl_Interp *interp, /* Interpreter in which substitution occurs */
+ Tcl_Obj *objPtr, /* The value to be substituted. */
+ int flags) /* What substitutions to do. */
+{
+ NRE_callback *rootPtr = TOP_CB(interp);
+
+ if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags),
+ rootPtr) != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NRSubstObj --
+ *
+ * Request substitution of a Tcl value by the NR stack.
+ *
+ * Results:
+ * Returns TCL_OK.
+ *
+ * Side effects:
+ * Compiles objPtr into bytecode that performs the substitutions as
+ * governed by flags and places callbacks on the NR stack to execute
+ * the bytecode and store the result in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_NRSubstObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int flags)
+{
+ ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags);
+
+ /* TODO: Confirm we do not need this. */
+ /* Tcl_ResetResult(interp); */
+ return TclNRExecuteByteCode(interp, codePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileSubstObj --
+ *
+ * Compile a Tcl value into ByteCode implementing its substitution, as
+ * governed by flags.
+ *
+ * Results:
+ * A (ByteCode *) is returned pointing to the resulting ByteCode.
+ * The caller must manage its refCount and arrange for a call to
+ * TclCleanupByteCode() when the last reference disappears.
+ *
+ * Side effects:
+ * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the
+ * ByteCode and governing flags value are kept in the internal rep for
+ * faster operations the next time CompileSubstObj is called on the same
+ * value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ByteCode *
+CompileSubstObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int flags)
+{
+ Interp *iPtr = (Interp *) interp;
+ ByteCode *codePtr = NULL;
+
+ if (objPtr->typePtr == &substCodeType) {
+ Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
+
+ codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
+ if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value
+ || ((Interp *) *codePtr->interpHandle != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)
+ || (codePtr->nsPtr != nsPtr)
+ || (codePtr->nsEpoch != nsPtr->resolverEpoch)
+ || (codePtr->localCachePtr !=
+ iPtr->varFramePtr->localCachePtr)) {
+ FreeSubstCodeInternalRep(objPtr);
+ }
+ }
+ if (objPtr->typePtr != &substCodeType) {
+ CompileEnv compEnv;
+ int numBytes;
+ const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+
+ /* TODO: Check for more TIP 280 */
+ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
+
+ TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
+
+ TclEmitOpcode(INST_DONE, &compEnv);
+ TclInitByteCodeObj(objPtr, &compEnv);
+ objPtr->typePtr = &substCodeType;
+ TclFreeCompileEnv(&compEnv);
+
+ codePtr = objPtr->internalRep.otherValuePtr;
+ 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? */
+ }
+ return codePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeSubstCodeInternalRep --
+ *
+ * Part of the substcode Tcl object type implementation. Frees the
+ * storage associated with a substcode object's internal representation
+ * unless its code is actively being executed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The substcode object's internal rep is marked invalid and its code
+ * gets freed unless the code is actively being executed. In that case
+ * the cleanup is delayed until the last execution of the code completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeSubstCodeInternalRep(
+ register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
+{
+ register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
+
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
}
/*
@@ -893,11 +1118,11 @@ TclInitCompileEnv(
envPtr->maxExceptDepth = 0;
envPtr->maxStackDepth = 0;
envPtr->currStackDepth = 0;
- TclInitLiteralTable(&(envPtr->localLitTable));
+ TclInitLiteralTable(&envPtr->localLitTable);
envPtr->codeStart = envPtr->staticCodeSpace;
envPtr->codeNext = envPtr->codeStart;
- envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
+ envPtr->codeEnd = envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES;
envPtr->mallocedCodeArray = 0;
envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
@@ -924,40 +1149,71 @@ TclInitCompileEnv(
* non-compiling evaluator
*/
- envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
+ envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
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) || (invoker->type == TCL_LOCATION_EVAL_LIST)) {
+ /*
* Initialize the compiler for relative counting in case of a
* dynamic context.
*/
envPtr->line = 1;
- envPtr->extCmdMapPtr->type =
+ if (iPtr->evalFlags & TCL_EVAL_FILE) {
+ iPtr->evalFlags &= ~TCL_EVAL_FILE;
+ envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE;
+
+ if (iPtr->scriptFile) {
+ /*
+ * Normalization here, to have the correct pwd. Should have
+ * negligible impact on performance, as the norm should have
+ * been done already by the 'source' invoking us, and it
+ * caches the result.
+ */
+
+ Tcl_Obj *norm =
+ Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
+
+ if (norm == NULL) {
+ /*
+ * Error message in the interp result. No place to put it.
+ * And no place to serve the error itself to either. Fake
+ * a path, empty string.
+ */
+
+ TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
+ } else {
+ envPtr->extCmdMapPtr->path = norm;
+ }
+ } else {
+ TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
+ }
+
+ Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
+ } else {
+ envPtr->extCmdMapPtr->type =
(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
+ }
} else {
- /*
+ /*
* Initialize the compiler using the context, making counting absolute
* to that context. Note that the context can be byte code execution.
* In that case we have to fill out the missing pieces (line, path,
* ...) which may make change the type as well.
*/
- CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
int pc = 0;
*ctxPtr = *invoker;
-
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
- * ctx.data.tebc.codePtr is used instead.
+ * ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc(ctxPtr);
@@ -977,6 +1233,7 @@ TclInitCompileEnv(
/*
* The reference made by 'TclGetSrcInfoForPc' is dead.
*/
+
Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
} else {
@@ -997,7 +1254,7 @@ TclInitCompileEnv(
* We have a new reference here.
*/
- Tcl_IncrRefCount(ctxPtr->data.eval.path);
+ Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
}
}
}
@@ -1008,12 +1265,12 @@ TclInitCompileEnv(
envPtr->extCmdMapPtr->start = envPtr->line;
/*
- * Initialize the data about invisible continuation lines as empty,
- * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if
- * such data is available.
+ * Initialize the data about invisible continuation lines as empty, i.e.
+ * not used. The caller (TclSetByteCodeFromAny) will set this up, if such
+ * data is available.
*/
- envPtr->clLoc = NULL;
+ envPtr->clLoc = NULL;
envPtr->clNext = NULL;
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
@@ -1048,27 +1305,27 @@ void
TclFreeCompileEnv(
register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
- if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) {
- ckfree((char *) envPtr->localLitTable.buckets);
+ if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
+ ckfree(envPtr->localLitTable.buckets);
envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
}
if (envPtr->mallocedCodeArray) {
- ckfree((char *) envPtr->codeStart);
+ ckfree(envPtr->codeStart);
}
if (envPtr->mallocedLiteralArray) {
- ckfree((char *) envPtr->literalArrayPtr);
+ ckfree(envPtr->literalArrayPtr);
}
if (envPtr->mallocedExceptArray) {
- ckfree((char *) envPtr->exceptArrayPtr);
+ ckfree(envPtr->exceptArrayPtr);
}
if (envPtr->mallocedCmdMap) {
- ckfree((char *) envPtr->cmdMapPtr);
+ ckfree(envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
- ckfree((char *) envPtr->auxDataArrayPtr);
+ ckfree(envPtr->auxDataArrayPtr);
}
if (envPtr->extCmdMapPtr) {
- ckfree((char *) envPtr->extCmdMapPtr);
+ ckfree(envPtr->extCmdMapPtr);
}
/*
@@ -1078,7 +1335,7 @@ TclFreeCompileEnv(
*/
if (envPtr->clLoc) {
- Tcl_Release (envPtr->clLoc);
+ Tcl_Release(envPtr->clLoc);
}
}
@@ -1142,6 +1399,7 @@ TclWordKnownAtCompileTime(
char utfBuf[TCL_UTF_MAX];
int length = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfBuf);
+
Tcl_AppendToObj(tempPtr, utfBuf, length);
}
break;
@@ -1192,9 +1450,9 @@ TclCompileScript(
{
Interp *iPtr = (Interp *) interp;
int lastTopLevelCmdIndex = -1;
- /* Index of most recent toplevel command in
- * the command location table. Initialized to
- * avoid compiler warning. */
+ /* 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;
@@ -1202,15 +1460,12 @@ TclCompileScript(
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
- int bytesLeft, isFirstCmd, wordIdx, currCmdIndex;
- int commandLength, objIndex;
+ int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex;
Tcl_DString ds;
/* TIP #280 */
ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
- int *wlines, wlineat, cmdLine;
- int* clNext;
- Tcl_Parse *parsePtr = (Tcl_Parse *)
- TclStackAlloc(interp, sizeof(Tcl_Parse));
+ int *wlines, wlineat, cmdLine, *clNext;
+ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
Tcl_DStringInit(&ds);
@@ -1249,6 +1504,19 @@ TclCompileScript(
TclCompileSyntaxError(interp, envPtr);
break;
}
+
+ /*
+ * 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.
+ */
+
+ TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
+ TclAdvanceContinuations(&cmdLine, &clNext,
+ parsePtr->commandStart - envPtr->source);
+
if (parsePtr->numWords > 0) {
int expand = 0; /* Set if there are dynamic expansions to
* handle */
@@ -1271,7 +1539,7 @@ TclCompileScript(
*/
commandLength = parsePtr->commandSize;
- if (parsePtr->term == parsePtr->commandStart + commandLength - 1) {
+ 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
@@ -1302,7 +1570,7 @@ TclCompileScript(
for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
wordIdx < parsePtr->numWords;
- wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
expand = 1;
break;
@@ -1310,9 +1578,9 @@ TclCompileScript(
}
envPtr->numCommands++;
- currCmdIndex = (envPtr->numCommands - 1);
+ currCmdIndex = envPtr->numCommands - 1;
lastTopLevelCmdIndex = currCmdIndex;
- startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ startCodeOffset = envPtr->codeNext - envPtr->codeStart;
EnterCmdStartData(envPtr, currCmdIndex,
parsePtr->commandStart - envPtr->source, startCodeOffset);
@@ -1333,13 +1601,10 @@ TclCompileScript(
* 'wlines'.
*/
- TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
- TclAdvanceContinuations (&cmdLine, &clNext,
- parsePtr->commandStart - envPtr->source);
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
- parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
- clNext, &wlines, envPtr);
+ parsePtr->tokenPtr, parsePtr->commandStart,
+ parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
/*
@@ -1349,11 +1614,10 @@ TclCompileScript(
for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
wordIdx < parsePtr->numWords; wordIdx++,
- tokenPtr += (tokenPtr->numComponents + 1)) {
+ tokenPtr += tokenPtr->numComponents + 1) {
envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
- envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx];
-
+ envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx];
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* The word is not a simple string of characters.
@@ -1392,6 +1656,7 @@ TclCompileScript(
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 savedNumCmds = envPtr->numCommands;
@@ -1404,7 +1669,7 @@ TclCompileScript(
* 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
- * TclExecuteByteCode(). Do emit an INST_START_CMD in
+ * 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
@@ -1437,8 +1702,8 @@ TclCompileScript(
update = 1;
}
- code = (cmdPtr->compileProc)(interp, parsePtr,
- cmdPtr, envPtr);
+ code = cmdPtr->compileProc(interp, parsePtr, cmdPtr,
+ envPtr);
if (code == TCL_OK) {
if (update) {
@@ -1454,54 +1719,46 @@ TclCompileScript(
TclStoreInt4AtPtr(fixLen, fixPtr);
}
goto finishCommand;
- } else {
- 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);
- }
+ }
+ if (envPtr->atCmdStart && savedCodeNext != 0) {
/*
- * Restore numCommands and codeNext to their
- * correct values, removing any commands compiled
- * before the failure to produce bytecode got
- * reported. [Bugs 705406 and 735055]
+ * 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!
*/
- envPtr->numCommands = savedNumCmds;
- envPtr->codeNext = envPtr->codeStart+savedCodeNext;
+ 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;
}
/*
* No compile procedure so push the word. If the command
* was found, push a CmdName object to reduce runtime
- * lookups. Avoid sharing this literal among different
- * namespaces to reduce shimmering.
+ * lookups. Mark this as a command name literal to reduce
+ * shimmering.
*/
- objIndex = TclRegisterNewNSLiteral(envPtr,
+ objIndex = TclRegisterNewCmdLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
if (cmdPtr != NULL) {
TclSetCmdNameObj(interp,
- envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr);
- }
- if ((wordIdx == 0) && (parsePtr->numWords == 1)) {
- /*
- * Single word script: unshare the command name to
- * avoid shimmering between bytecode and cmdName
- * representations [Bug 458361]
- */
-
- TclHideLiteral(interp, envPtr, objIndex);
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ cmdPtr);
}
} else {
/*
@@ -1512,13 +1769,15 @@ TclCompileScript(
* unmodified. We care only if the we are in a context
* which already allows absolute counting.
*/
+
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
if (envPtr->clNext) {
- TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr,
- tokenPtr[1].start - envPtr->source,
- eclPtr->loc [wlineat].next [wordIdx]);
+ TclContinuationsEnterDerived(
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ tokenPtr[1].start - envPtr->source,
+ eclPtr->loc[wlineat].next[wordIdx]);
}
}
TclEmitPush(objIndex, envPtr);
@@ -1554,10 +1813,11 @@ TclCompileScript(
*/
int isnew;
- Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
- (char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
- Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
+ Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
+ INT2PTR(envPtr->codeNext - envPtr->codeStart),
+ &isnew);
+ Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
if (wordIdx <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
@@ -1580,8 +1840,8 @@ TclCompileScript(
* reduced form now
*/
- ckfree((char *) eclPtr->loc[wlineat].line);
- ckfree((char *) eclPtr->loc[wlineat].next);
+ 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 */
@@ -1599,26 +1859,28 @@ TclCompileScript(
*/
TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
- TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source);
+ 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.
- *
- * WARNING: push an unshared object! If the script being compiled is a
- * shared empty string, it will otherwise be self-referential and cause
- * difficulties with literal management [Bugs 467523, 983660]. We used to
- * have special code in TclReleaseLiteral to handle this particular
- * self-reference, but now opt for avoiding its creation altogether.
*/
if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
- envPtr->numSrcBytes = (p - script);
+ envPtr->numSrcBytes = p - script;
TclStackFree(interp, parsePtr);
Tcl_DStringFree(&ds);
}
@@ -1645,6 +1907,76 @@ TclCompileScript(
*/
void
+TclCompileVarSubst(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ CompileEnv *envPtr)
+{
+ const char *p, *name = tokenPtr[1].start;
+ int nameBytes = tokenPtr[1].size;
+ int i, localVar, localVarName = 1;
+
+ /*
+ * Determine how the variable name should be handled: if it contains any
+ * namespace qualifiers it is not a local variable (localVarName=-1); if
+ * it looks like an array element and the token has a single component, it
+ * should not be created here [Bug 569438] (localVarName=0); otherwise,
+ * the local variable can safely be created (localVarName=1).
+ */
+
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {
+ localVarName = -1;
+ break;
+ } else if ((*p == '(')
+ && (tokenPtr->numComponents == 1)
+ && (*(name + nameBytes - 1) == ')')) {
+ localVarName = 0;
+ break;
+ }
+ }
+
+ /*
+ * Either push the variable's name, or find its index in the array
+ * of local variables in a procedure frame.
+ */
+
+ localVar = -1;
+ if (localVarName != -1) {
+ localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
+ }
+ if (localVar < 0) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr);
+ }
+
+ /*
+ * Emit instructions to load the variable.
+ */
+
+ TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
+ tokenPtr[1].start + tokenPtr[1].size);
+
+ if (tokenPtr->numComponents == 1) {
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
+ }
+ } else {
+ TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr);
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
+ }
+ }
+}
+
+void
TclCompileTokens(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
@@ -1656,44 +1988,41 @@ TclCompileTokens(
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
- const char *name, *p;
- int numObjsToConcat, nameBytes, localVarName, localVar;
- int length, i;
+ int i, numObjsToConcat, length;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
- int* clPosition = NULL;
+ int *clPosition = NULL;
/*
* For the handling of continuation lines in literals we first check if
* this is actually a literal. For if not we can forego the additional
* processing. Otherwise we pre-allocate a small table to store the
- * locations of all continuation lines we find in this literal, if
- * any. The table is extended if needed.
+ * locations of all continuation lines we find in this literal, if any.
+ * The table is extended if needed.
*
- * Note: Different to the equivalent code in function
- * 'TclSubstTokens()' (see file "tclParse.c") we do not seem to need
- * the 'adjust' variable. We also do not seem to need code which merges
- * continuation line information of multiple words which concat'd at
- * runtime. Either that or I have not managed to find a test case for
- * these two possibilities yet. It might be a difference between compile-
- * versus runtime processing.
+ * Note: Different to the equivalent code in function 'TclSubstTokens()'
+ * (see file "tclParse.c") we do not seem to need the 'adjust' variable.
+ * We also do not seem to need code which merges continuation line
+ * information of multiple words which concat'd at runtime. Either that or
+ * I have not managed to find a test case for these two possibilities yet.
+ * It might be a difference between compile- versus run-time processing.
*/
- numCL = 0;
- maxNumCL = 0;
+ numCL = 0;
+ maxNumCL = 0;
isLiteral = 1;
for (i=0 ; i < count; i++) {
- if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
- (tokenPtr[i].type != TCL_TOKEN_BS)) {
+ if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
+ && (tokenPtr[i].type != TCL_TOKEN_BS)) {
isLiteral = 0;
break;
}
}
if (isLiteral) {
- maxNumCL = NUM_STATIC_POS;
- clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
+ maxNumCL = NUM_STATIC_POS;
+ clPosition = ckalloc(maxNumCL * sizeof(int));
}
Tcl_DStringInit(&textBuffer);
@@ -1702,6 +2031,8 @@ TclCompileTokens(
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size);
+ TclAdvanceLines(&envPtr->line, tokenPtr->start,
+ tokenPtr->start + tokenPtr->size);
break;
case TCL_TOKEN_BS:
@@ -1727,12 +2058,12 @@ TclCompileTokens(
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
- int clPos = Tcl_DStringLength (&textBuffer);
+ int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = (int*) ckrealloc ((char*)clPosition,
- maxNumCL*sizeof(int));
+ clPosition = ckrealloc(clPosition,
+ maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
@@ -1755,8 +2086,9 @@ TclCompileTokens(
Tcl_DStringFree(&textBuffer);
if (numCL) {
- TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
- numCL, clPosition);
+ TclContinuationsEnter(
+ envPtr->literalArrayPtr[literal].objPtr, numCL,
+ clPosition);
}
numCL = 0;
}
@@ -1782,71 +2114,7 @@ TclCompileTokens(
Tcl_DStringFree(&textBuffer);
}
- /*
- * Determine how the variable name should be handled: if it
- * contains any namespace qualifiers it is not a local variable
- * (localVarName=-1); if it looks like an array element and the
- * token has a single component, it should not be created here
- * [Bug 569438] (localVarName=0); otherwise, the local variable
- * can safely be created (localVarName=1).
- */
-
- name = tokenPtr[1].start;
- nameBytes = tokenPtr[1].size;
- localVarName = -1;
- if (envPtr->procPtr != NULL) {
- localVarName = 1;
- for (i = 0, p = name; i < nameBytes; i++, p++) {
- if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {
- localVarName = -1;
- break;
- } else if ((*p == '(')
- && (tokenPtr->numComponents == 1)
- && (*(name + nameBytes - 1) == ')')) {
- localVarName = 0;
- break;
- }
- }
- }
-
- /*
- * Either push the variable's name, or find its index in the array
- * of local variables in a procedure frame.
- */
-
- localVar = -1;
- if (localVarName != -1) {
- localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
- envPtr->procPtr);
- }
- if (localVar < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
- envPtr);
- }
-
- /*
- * Emit instructions to load the variable.
- */
-
- if (tokenPtr->numComponents == 1) {
- if (localVar < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- } else if (localVar <= 255) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
- }
- } else {
- TclCompileTokens(interp, tokenPtr+2,
- tokenPtr->numComponents-1, envPtr);
- if (localVar < 0) {
- TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
- } else if (localVar <= 255) {
- TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
- }
- }
+ TclCompileVarSubst(interp, tokenPtr, envPtr);
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
@@ -1872,7 +2140,7 @@ TclCompileTokens(
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
- numCL, clPosition);
+ numCL, clPosition);
}
numCL = 0;
}
@@ -1899,12 +2167,12 @@ TclCompileTokens(
Tcl_DStringFree(&textBuffer);
/*
- * Release the temp table we used to collect the locations of
- * continuation lines, if any.
+ * Release the temp table we used to collect the locations of continuation
+ * lines, if any.
*/
if (maxNumCL) {
- ckfree ((char*) clPosition);
+ ckfree(clPosition);
}
}
@@ -1998,7 +2266,7 @@ TclCompileExprWords(
*/
if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
- TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1);
+ TclCompileExpr(interp, tokenPtr[1].start,tokenPtr[1].size, envPtr, 1);
return;
}
@@ -2013,7 +2281,7 @@ TclCompileExprWords(
if (i < (numWords - 1)) {
TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);
}
- wordPtr += (wordPtr->numComponents + 1);
+ wordPtr += wordPtr->numComponents + 1;
}
concatItems = 2*numWords - 1;
while (concatItems > 255) {
@@ -2038,8 +2306,8 @@ TclCompileExprWords(
*
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
- * result is pushed onto the stack: the compiler has to take care of this
- * itself if the last compiled command is a NoOp.
+ * result is pushed onto the stack: the compiler has to take care of this
+ * itself if the last compiled command is a NoOp.
*
*----------------------------------------------------------------------
*/
@@ -2058,7 +2326,7 @@ TclCompileNoOp(
int savedStackDepth = envPtr->currStackDepth;
tokenPtr = parsePtr->tokenPtr;
- for(i = 1; i < parsePtr->numWords; i++) {
+ for (i = 1; i < parsePtr->numWords; i++) {
tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
envPtr->currStackDepth = savedStackDepth;
@@ -2120,10 +2388,10 @@ TclInitByteCodeObj(
iPtr = envPtr->iPtr;
- codeBytes = (envPtr->codeNext - envPtr->codeStart);
- objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
- exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
- auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
+ codeBytes = envPtr->codeNext - envPtr->codeStart;
+ objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *);
+ exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
@@ -2143,7 +2411,7 @@ TclInitByteCodeObj(
namespacePtr = envPtr->iPtr->globalNsPtr;
}
- p = (unsigned char *) ckalloc((size_t) structureSize);
+ p = ckalloc(structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
codePtr->compileEpoch = iPtr->compileEpoch;
@@ -2212,7 +2480,7 @@ TclInitByteCodeObj(
#ifdef TCL_COMPILE_STATS
codePtr->structureSize = structureSize
- (sizeof(size_t) + sizeof(Tcl_Time));
- Tcl_GetTime(&(codePtr->createTime));
+ Tcl_GetTime(&codePtr->createTime);
RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
@@ -2223,7 +2491,7 @@ TclInitByteCodeObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = (void *) codePtr;
+ objPtr->internalRep.otherValuePtr = codePtr;
objPtr->typePtr = &tclByteCodeType;
/*
@@ -2231,7 +2499,7 @@ TclInitByteCodeObj(
* byte code object (internal rep), for use with the bc compiler.
*/
- Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr,
+ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr,
&isNew), envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
@@ -2271,18 +2539,47 @@ TclFindCompiledLocal(
int nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
- register Proc *procPtr) /* Points to structure describing procedure
- * containing the variable reference. */
+ CompileEnv *envPtr) /* Points to the current compile environment*/
{
register CompiledLocal *localPtr;
int localVar = -1;
register int i;
+ Proc *procPtr;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
+ procPtr = envPtr->procPtr;
+
+ if (procPtr == NULL) {
+ /*
+ * Compiling a non-body script: give it read access to the LVT in the
+ * current localCache
+ */
+
+ LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
+ const char *localName;
+ Tcl_Obj **varNamePtr;
+ int len;
+
+ if (!cachePtr || !name) {
+ return -1;
+ }
+
+ varNamePtr = &cachePtr->varName0;
+ for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
+ if (*varNamePtr) {
+ localName = Tcl_GetStringFromObj(*varNamePtr, &len);
+ if ((len == nameBytes) && !strncmp(name, localName, len)) {
+ return i;
+ }
+ }
+ }
+ return -1;
+ }
+
if (name != NULL) {
int localCt = procPtr->numCompiledLocals;
@@ -2306,9 +2603,7 @@ TclFindCompiledLocal(
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
- localPtr = (CompiledLocal *) ckalloc((unsigned)
- (sizeof(CompiledLocal) - sizeof(localPtr->name)
- + nameBytes + 1));
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -2358,7 +2653,7 @@ TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
- CompileEnv *envPtr = (CompileEnv *) envArgPtr;
+ CompileEnv *envPtr = envArgPtr;
/* The CompileEnv containing the code array to
* be doubled in size. */
@@ -2368,25 +2663,26 @@ TclExpandCodeArray(
* [inclusive].
*/
- size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
- size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
+ size_t currBytes = envPtr->codeNext - envPtr->codeStart;
+ size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
- envPtr->codeStart = (unsigned char *)
- ckrealloc((char *)envPtr->codeStart, newBytes);
+ envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes);
} else {
/*
- * envPtr->codeStart isn't a ckalloc'd pointer, so we must
- * code a ckrealloc equivalent for ourselves.
+ * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
+ * ckrealloc equivalent for ourselves.
*/
- unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
+
+ unsigned char *newPtr = ckalloc(newBytes);
+
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
envPtr->mallocedCodeArray = 1;
}
- envPtr->codeNext = (envPtr->codeStart + currBytes);
- envPtr->codeEnd = (envPtr->codeStart + newBytes);
+ envPtr->codeNext = envPtr->codeStart + currBytes;
+ envPtr->codeEnd = envPtr->codeStart + newBytes;
}
/*
@@ -2433,19 +2729,20 @@ EnterCmdStartData(
*/
size_t currElems = envPtr->cmdMapEnd;
- size_t newElems = 2*currElems;
+ size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
- envPtr->cmdMapPtr = (CmdLocation *)
- ckrealloc((char *) envPtr->cmdMapPtr, newBytes);
+ envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
- * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must
- * code a ckrealloc equivalent for ourselves.
+ * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
+ * ckrealloc equivalent for ourselves.
*/
- CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
+
+ CmdLocation *newPtr = ckalloc(newBytes);
+
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
envPtr->mallocedCmdMap = 1;
@@ -2459,7 +2756,7 @@ EnterCmdStartData(
}
}
- cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcBytes = -1;
@@ -2508,7 +2805,7 @@ EnterCmdExtentData(
cmdIndex);
}
- cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
@@ -2544,14 +2841,13 @@ EnterCmdWordData(
int len,
int numWords,
int line,
- int* clNext,
+ int *clNext,
int **wlines,
- CompileEnv* envPtr)
+ CompileEnv *envPtr)
{
ECL *ePtr;
const char *last;
- int wordIdx, wordLine, *wwlines;
- int* wordNext;
+ int wordIdx, wordLine, *wwlines, *wordNext;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
@@ -2564,25 +2860,25 @@ EnterCmdWordData(
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
- eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes);
+ eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
- ePtr->line = (int *) ckalloc(numWords * sizeof(int));
- ePtr->next = (int**) ckalloc (numWords * sizeof (int*));
+ ePtr->line = ckalloc(numWords * sizeof(int));
+ ePtr->next = ckalloc(numWords * sizeof(int *));
ePtr->nline = numWords;
- wwlines = (int *) ckalloc(numWords * sizeof(int));
+ wwlines = ckalloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
wordNext = clNext;
for (wordIdx=0 ; wordIdx<numWords;
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
- TclAdvanceLines (&wordLine, last, tokenPtr->start);
- TclAdvanceContinuations (&wordLine, &wordNext,
- tokenPtr->start - envPtr->source);
+ TclAdvanceLines(&wordLine, last, tokenPtr->start);
+ TclAdvanceContinuations(&wordLine, &wordNext,
+ tokenPtr->start - envPtr->source);
wwlines[wordIdx] =
(TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1);
ePtr->line[wordIdx] = wordLine;
@@ -2636,15 +2932,16 @@ TclCreateExceptRange(
size_t newBytes = newElems * sizeof(ExceptionRange);
if (envPtr->mallocedExceptArray) {
- envPtr->exceptArrayPtr = (ExceptionRange *)
- ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes);
+ envPtr->exceptArrayPtr =
+ ckrealloc(envPtr->exceptArrayPtr, newBytes);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- ExceptionRange *newPtr = (ExceptionRange *)
- ckalloc((unsigned) newBytes);
+
+ ExceptionRange *newPtr = ckalloc(newBytes);
+
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
envPtr->exceptArrayPtr = newPtr;
envPtr->mallocedExceptArray = 1;
@@ -2653,7 +2950,7 @@ TclCreateExceptRange(
}
envPtr->exceptArrayNext++;
- rangePtr = &(envPtr->exceptArrayPtr[index]);
+ rangePtr = &envPtr->exceptArrayPtr[index];
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
rangePtr->codeOffset = -1;
@@ -2691,14 +2988,14 @@ int
TclCreateAuxData(
ClientData clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
- AuxDataType *typePtr, /* Pointer to the type to attach to this
+ const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
register CompileEnv *envPtr)/* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
- /* Points to the new AuxData structure */
+ /* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
@@ -2713,14 +3010,16 @@ TclCreateAuxData(
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
- envPtr->auxDataArrayPtr = (AuxData *)
- ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes);
+ envPtr->auxDataArrayPtr =
+ ckrealloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
+
+ AuxData *newPtr = ckalloc(newBytes);
+
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
envPtr->mallocedAuxDataArray = 1;
@@ -2729,7 +3028,7 @@ TclCreateAuxData(
}
envPtr->auxDataArrayNext++;
- auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
+ auxDataPtr = &envPtr->auxDataArrayPtr[index];
auxDataPtr->clientData = clientData;
auxDataPtr->type = typePtr;
return index;
@@ -2760,7 +3059,7 @@ TclInitJumpFixupArray(
{
fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
fixupArrayPtr->next = 0;
- fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
+ fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1;
fixupArrayPtr->mallocedArray = 0;
}
@@ -2787,8 +3086,8 @@ TclInitJumpFixupArray(
void
TclExpandJumpFixupArray(
register JumpFixupArray *fixupArrayPtr)
- /* Points to the JumpFixupArray structure
- * to enlarge. */
+ /* Points to the JumpFixupArray structure to
+ * enlarge. */
{
/*
* The currently allocated jump fixup entries are stored from fixup[0] up
@@ -2801,14 +3100,15 @@ TclExpandJumpFixupArray(
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
- fixupArrayPtr->fixup = (JumpFixup *)
- ckrealloc((char *)(fixupArrayPtr->fixup), newBytes);
+ fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
- * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must
- * code a ckrealloc equivalent for ourselves.
+ * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
+ * ckrealloc equivalent for ourselves.
*/
- JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
+
+ JumpFixup *newPtr = ckalloc(newBytes);
+
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
fixupArrayPtr->mallocedArray = 1;
@@ -2839,7 +3139,7 @@ TclFreeJumpFixupArray(
* free. */
{
if (fixupArrayPtr->mallocedArray) {
- ckfree((char *) fixupArrayPtr->fixup);
+ ckfree(fixupArrayPtr->fixup);
}
}
@@ -2884,7 +3184,7 @@ TclEmitForwardJump(
*/
jumpFixupPtr->jumpType = jumpType;
- jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
+ jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart;
jumpFixupPtr->cmdIndex = envPtr->numCommands;
jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
@@ -2942,7 +3242,7 @@ TclFixupForwardJump(
unsigned numBytes;
if (jumpDist <= distThreshold) {
- jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
+ jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
@@ -2967,7 +3267,7 @@ TclFixupForwardJump(
if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
TclExpandCodeArray(envPtr);
}
- jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
+ jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
numBytes = envPtr->codeNext-jumpPc-2;
p = jumpPc+2;
memmove(p+3, p, numBytes);
@@ -2992,19 +3292,19 @@ TclFixupForwardJump(
*/
firstCmd = jumpFixupPtr->cmdIndex;
- lastCmd = (envPtr->numCommands - 1);
+ lastCmd = envPtr->numCommands - 1;
if (firstCmd < lastCmd) {
for (k = firstCmd; k <= lastCmd; k++) {
- (envPtr->cmdMapPtr[k]).codeOffset += 3;
+ envPtr->cmdMapPtr[k].codeOffset += 3;
}
}
firstRange = jumpFixupPtr->exceptIndex;
- lastRange = (envPtr->exceptArrayNext - 1);
+ lastRange = envPtr->exceptArrayNext - 1;
for (k = firstRange; k <= lastRange; k++) {
- ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
- rangePtr->codeOffset += 3;
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k];
+ rangePtr->codeOffset += 3;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
@@ -3042,7 +3342,7 @@ TclFixupForwardJump(
*----------------------------------------------------------------------
*/
-void * /* == InstructionDesc* == */
+const void * /* == InstructionDesc* == */
TclGetInstructionTable(void)
{
return &tclInstructionTable[0];
@@ -3069,7 +3369,7 @@ TclGetInstructionTable(void)
void
TclRegisterAuxDataType(
- AuxDataType *typePtr) /* Information about object type; storage must
+ const AuxDataType *typePtr) /* Information about object type; storage must
* be statically allocated (must live forever;
* will not be deallocated). */
{
@@ -3118,12 +3418,12 @@ TclRegisterAuxDataType(
*----------------------------------------------------------------------
*/
-AuxDataType *
+const AuxDataType *
TclGetAuxDataType(
- char *typeName) /* Name of AuxData type to look up. */
+ const char *typeName) /* Name of AuxData type to look up. */
{
register Tcl_HashEntry *hPtr;
- AuxDataType *typePtr = NULL;
+ const AuxDataType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
@@ -3132,7 +3432,7 @@ TclGetAuxDataType(
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
if (hPtr != NULL) {
- typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
+ typePtr = Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
@@ -3241,13 +3541,13 @@ GetCmdLocEncodingSize(
codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
prevCodeOffset = prevSrcOffset = 0;
for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
+ codeDelta = mapPtr[i].codeOffset - prevCodeOffset;
if (codeDelta < 0) {
Tcl_Panic("GetCmdLocEncodingSize: bad code offset");
} else if (codeDelta <= 127) {
codeDeltaNext++;
} else {
- codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
+ codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
}
prevCodeOffset = mapPtr[i].codeOffset;
@@ -3257,14 +3557,14 @@ GetCmdLocEncodingSize(
} else if (codeLen <= 127) {
codeLengthNext++;
} else {
- codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ codeLengthNext += 5;/* 1 byte for 0xFF, 4 for length */
}
- srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDelta = mapPtr[i].srcOffset - prevSrcOffset;
+ if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) {
srcDeltaNext++;
} else {
- srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
+ srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
}
prevSrcOffset = mapPtr[i].srcOffset;
@@ -3274,7 +3574,7 @@ GetCmdLocEncodingSize(
} else if (srcLen <= 127) {
srcLengthNext++;
} else {
- srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
}
}
@@ -3326,7 +3626,7 @@ EncodeCmdLocMap(
codePtr->codeDeltaStart = p;
prevOffset = 0;
for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevOffset);
+ codeDelta = mapPtr[i].codeOffset - prevOffset;
if (codeDelta < 0) {
Tcl_Panic("EncodeCmdLocMap: bad code offset");
} else if (codeDelta <= 127) {
@@ -3368,8 +3668,8 @@ EncodeCmdLocMap(
codePtr->srcDeltaStart = p;
prevOffset = 0;
for (i = 0; i < numCmds; i++) {
- srcDelta = (mapPtr[i].srcOffset - prevOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDelta = mapPtr[i].srcOffset - prevOffset;
+ if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) {
TclStoreInt1AtPtr(srcDelta, p);
p++;
} else {
@@ -3453,7 +3753,7 @@ TclPrintByteCodeObj(
int
TclPrintInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
- unsigned char *pc) /* Points to first byte of instruction. */
+ const unsigned char *pc) /* Points to first byte of instruction. */
{
Tcl_Obj *bufferObj;
int numBytes;
@@ -3560,7 +3860,7 @@ TclDisassembleByteCodeObj(
}
codeStart = codePtr->codeStart;
- codeLimit = (codeStart + codePtr->numCodeBytes);
+ codeLimit = codeStart + codePtr->numCodeBytes;
numCmds = codePtr->numCommands;
/*
@@ -3645,7 +3945,7 @@ TclDisassembleByteCodeObj(
Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n",
codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < codePtr->numExceptRanges; i++) {
- ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
+ ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
Tcl_AppendPrintfToObj(bufferObj,
" %d: level %d, %s, pc %d-%d, ",
@@ -3734,7 +4034,7 @@ TclDisassembleByteCodeObj(
}
Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
- ((i % 2)? " " : "\n "),
+ ((i % 2)? " " : "\n "),
(i+1), codeOffset, (codeOffset + codeLen - 1),
srcOffset, (srcOffset + srcLen - 1));
}
@@ -3823,12 +4123,12 @@ TclDisassembleByteCodeObj(
static int
FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
- unsigned char *pc, /* Points to first byte of instruction. */
+ const unsigned char *pc, /* Points to first byte of instruction. */
Tcl_Obj *bufferObj) /* Object to append instruction info to. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
- register InstructionDesc *instDesc = &tclInstructionTable[opCode];
+ register const InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
@@ -3924,7 +4224,7 @@ FormatInstruction(
}
}
if (suffixObj) {
- char *bytes;
+ const char *bytes;
int length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
@@ -3949,6 +4249,173 @@ FormatInstruction(
/*
*----------------------------------------------------------------------
*
+ * TclGetInnerContext --
+ *
+ * If possible, returns a list capturing the inner context. Otherwise
+ * return NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetInnerContext(
+ Tcl_Interp *interp,
+ const unsigned char *pc,
+ Tcl_Obj **tosPtr)
+{
+ int objc = 0, off = 0;
+ Tcl_Obj *result;
+ Interp *iPtr = (Interp *) interp;
+
+ switch (*pc) {
+ case INST_STR_LEN:
+ case INST_LNOT:
+ case INST_BITNOT:
+ case INST_UMINUS:
+ case INST_UPLUS:
+ case INST_TRY_CVT_TO_NUMERIC:
+ case INST_EXPAND_STKTOP:
+ case INST_EXPR_STK:
+ objc = 1;
+ break;
+
+ case INST_LIST_IN:
+ case INST_LIST_NOT_IN: /* Basic list containment operators. */
+ case INST_STR_EQ:
+ case INST_STR_NEQ: /* String (in)equality check */
+ case INST_STR_CMP: /* String compare. */
+ case INST_STR_INDEX:
+ case INST_STR_MATCH:
+ case INST_REGEXP:
+ case INST_EQ:
+ case INST_NEQ:
+ case INST_LT:
+ case INST_GT:
+ case INST_LE:
+ 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:
+ objc = 2;
+ break;
+
+ case INST_RETURN_STK:
+ /* early pop. TODO: dig out opt dict too :/ */
+ objc = 1;
+ break;
+
+ case INST_SYNTAX:
+ case INST_RETURN_IMM:
+ objc = 2;
+ break;
+
+ case INST_INVOKE_STK4:
+ objc = TclGetUInt4AtPtr(pc+1);
+ break;
+
+ case INST_INVOKE_STK1:
+ objc = TclGetUInt1AtPtr(pc+1);
+ break;
+ }
+
+ result = iPtr->innerContext;
+ if (Tcl_IsShared(result)) {
+ Tcl_DecrRefCount(result);
+ iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
+ Tcl_IncrRefCount(result);
+ } else {
+ int len;
+
+ /*
+ * Reset while keeping the list intrep as much as possible.
+ */
+
+ Tcl_ListObjLength(interp, result, &len);
+ Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
+ }
+ Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
+
+ for (; objc>0 ; objc--) {
+ Tcl_Obj *objPtr;
+
+ objPtr = tosPtr[1 - objc + off];
+ if (!objPtr) {
+ Tcl_Panic("InnerContext: bad tos -- appending null object");
+ }
+ if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) {
+ Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
+ objPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, result, objPtr);
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewInstNameObj --
+ *
+ * Creates a new InstName Tcl_Obj based on the given instruction
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclNewInstNameObj(
+ unsigned char inst)
+{
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ objPtr->typePtr = &tclInstNameType;
+ objPtr->internalRep.longValue = (long) inst;
+ objPtr->bytes = NULL;
+
+ return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfInstName --
+ *
+ * Update the string representation for an instruction name object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfInstName(
+ Tcl_Obj *objPtr)
+{
+ int inst = objPtr->internalRep.longValue;
+ char *s, buf[20];
+ int len;
+
+ if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
+ sprintf(buf, "inst_%d", inst);
+ s = buf;
+ } else {
+ s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
+ }
+ len = strlen(s);
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, s, len + 1);
+ objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* PrintSourceToObj --
*
* Appends a quoted representation of a string to a Tcl_Obj.
@@ -4027,7 +4494,7 @@ RecordByteCodeStats(
* to add to accumulated statistics. */
{
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- register ByteCodeStats *statsPtr = &(iPtr->stats);
+ register ByteCodeStats *statsPtr = &iPtr->stats;
statsPtr->numCompilations++;
statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
@@ -4036,7 +4503,7 @@ RecordByteCodeStats(
statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
- statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;
+ statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++;
statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
statsPtr->currentLitBytes += (double)
@@ -4054,5 +4521,7 @@ RecordByteCodeStats(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c035a03..45d50ea 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -127,26 +127,25 @@ typedef struct CmdLocation {
typedef struct ECL {
int srcOffset; /* Command location to find the entry. */
- int nline; /* Number of words in the command */
+ int nline; /* Number of words in the command */
int *line; /* Line information for all words in the
* command. */
- int** next; /* Transient information used by the compiler
+ int **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
typedef struct ExtCmdLoc {
int type; /* Context type. */
- int start; /* Starting line for compiled script. Needed
+ int start; /* Starting line for compiled script. Needed
* for the extended recompile check in
- * TclCompEvalObj. */
-
+ * tclCompileObj. */
Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
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
+ 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
@@ -171,7 +170,7 @@ typedef struct ExtCmdLoc {
*/
typedef ClientData (AuxDataDupProc) (ClientData clientData);
-typedef void (AuxDataFreeProc) (ClientData clientData);
+typedef void (AuxDataFreeProc) (ClientData clientData);
typedef void (AuxDataPrintProc)(ClientData clientData,
Tcl_Obj *appendObj, struct ByteCode *codePtr,
unsigned int pcOffset);
@@ -184,7 +183,7 @@ typedef void (AuxDataPrintProc)(ClientData clientData,
*/
typedef struct AuxDataType {
- char *name; /* The name of the type. Types can be
+ const char *name; /* The name of the type. Types can be
* registered and found by name */
AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux
* data is duplicated (e.g., when the ByteCode
@@ -207,7 +206,7 @@ typedef struct AuxDataType {
*/
typedef struct AuxData {
- AuxDataType *type; /* Pointer to the AuxData type associated with
+ const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
ClientData clientData; /* The compilation data itself. */
} AuxData;
@@ -311,13 +310,13 @@ typedef struct CompileEnv {
* 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. */
- int* clNext; /* If not NULL, it refers to the next slot in
- * clLoc to check for an invisible
- * continuation line. */
+ ContLineLoc *clLoc; /* If not NULL, the table holding the
+ * locations of the invisible continuation
+ * lines in the input script, to adjust the
+ * line counter. */
+ int *clNext; /* If not NULL, it refers to the next slot in
+ * clLoc to check for an invisible
+ * continuation line. */
} CompileEnv;
/*
@@ -342,6 +341,8 @@ typedef struct CompileEnv {
#define TCL_BYTECODE_RESOLVE_VARS 0x0002
+#define TCL_BYTECODE_RECOMPILE 0x0004
+
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
@@ -437,7 +438,7 @@ typedef struct ByteCode {
* code deltas. Source lengths are always
* positive. This sequence is just after the
* last byte in the source delta sequence. */
- LocalCache *localCachePtr; /* Pointer to the start of the cached variable
+ LocalCache *localCachePtr; /* Pointer to the start of the cached variable
* names and initialisation data for local
* variables. */
#ifdef TCL_COMPILE_STATS
@@ -665,8 +666,18 @@ typedef struct ByteCode {
#define INST_EXIST_ARRAY_STK 130
#define INST_EXIST_STK 131
+/* For [subst] compilation */
+#define INST_NOP 132
+#define INST_RETURN_CODE_BRANCH 133
+
+/* For [unset] compilation */
+#define INST_UNSET_SCALAR 134
+#define INST_UNSET_ARRAY 135
+#define INST_UNSET_ARRAY_STK 136
+#define INST_UNSET_STK 137
+
/* The last opcode */
-#define LAST_INST_OPCODE 131
+#define LAST_INST_OPCODE 137
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -696,7 +707,7 @@ typedef enum InstOperandType {
} InstOperandType;
typedef struct InstructionDesc {
- char *name; /* Name of instruction. */
+ const char *name; /* Name of instruction. */
int numBytes; /* Total number of bytes for instruction. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
@@ -708,7 +719,7 @@ typedef struct InstructionDesc {
/* The type of each operand. */
} InstructionDesc;
-MODULE_SCOPE InstructionDesc tclInstructionTable[];
+MODULE_SCOPE InstructionDesc const tclInstructionTable[];
/*
* Compilation of some Tcl constructs such as if commands and the logical or
@@ -798,7 +809,7 @@ typedef struct ForeachInfo {
* LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
-MODULE_SCOPE AuxDataType tclForeachInfoType;
+MODULE_SCOPE const AuxDataType tclForeachInfoType;
/*
* Structure used to hold information about a switch command that is needed
@@ -811,7 +822,7 @@ typedef struct JumptableInfo {
* offsets). */
} JumptableInfo;
-MODULE_SCOPE AuxDataType tclJumptableInfoType;
+MODULE_SCOPE const AuxDataType tclJumptableInfoType;
/*
* Structure used to hold information about a [dict update] command that is
@@ -829,14 +840,14 @@ typedef struct {
* STRUCTURE. */
} DictUpdateInfo;
-MODULE_SCOPE AuxDataType tclDictUpdateInfoType;
+MODULE_SCOPE const AuxDataType tclDictUpdateInfoType;
/*
* ClientData type used by the math operator commands.
*/
typedef struct {
- const char *op; /* Do not call it 'operator': C++ reserved */
+ const char *op; /* Do not call it 'operator': C++ reserved */
const char *expected;
union {
int numArgs;
@@ -850,16 +861,16 @@ typedef struct {
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[],
- CONST char *command, int length, int flags);
+MODULE_SCOPE Tcl_NRPostProc NRCommand;
+MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine;
+
/*
*----------------------------------------------------------------
* Procedures exported by the engine to be used by tclBasic.c
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
const CmdFrame *invoker, int word);
/*
@@ -873,41 +884,43 @@ MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
-MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, CONST char *script,
- int numBytes, CompileEnv *envPtr, int optimize);
+MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
+ int numBytes, CompileEnv *envPtr, int optimize);
MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp,
- CONST char *script, int numBytes,
+ const char *script, int numBytes,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
+MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
- AuxDataType *typePtr, CompileEnv *envPtr);
+ const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
-MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp);
-MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
- int length, unsigned int hash, int *newPtr,
- Namespace *nsPtr, int flags,
- LiteralEntry **globalPtrPtr);
+MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
+ int length, unsigned int hash, int *newPtr,
+ Namespace *nsPtr, int flags,
+ LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
- int catchOnly, ByteCode* codePtr);
+ int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
-MODULE_SCOPE int TclExecuteByteCode(Tcl_Interp *interp,
+MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void);
-MODULE_SCOPE int TclFindCompiledLocal(CONST char *name, int nameChars,
- int create, Proc *procPtr);
+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,
@@ -921,7 +934,7 @@ MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
MODULE_SCOPE void TclInitCompilation(void);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
- int numBytes, CONST CmdFrame* invoker, int word);
+ int numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
#ifdef TCL_COMPILE_STATS
@@ -932,34 +945,42 @@ MODULE_SCOPE int TclLog2(int value);
MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
#endif
-MODULE_SCOPE int TclPrintInstruction(ByteCode* codePtr,
- unsigned char *pc);
+MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr,
+ const unsigned char *pc);
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(AuxDataType *typePtr);
+ 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 TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
Tcl_Obj *valuePtr);
+MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
+ const char *script,
+ const char *command, int length,
+ const unsigned char *pc, Tcl_Obj **tosPtr);
+MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
+ const unsigned char *pc, Tcl_Obj **tosPtr);
+MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
+
/*
*----------------------------------------------------------------
@@ -968,31 +989,31 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*----------------------------------------------------------------
*/
-#define LITERAL_ON_HEAP 0x01
-#define LITERAL_NS_SCOPE 0x02
+#define LITERAL_ON_HEAP 0x01
+#define LITERAL_CMD_NAME 0x02
/*
- * Form of TclRegisterLiteral with onHeap == 0. In that case, it is safe to
- * cast away CONSTness, and it is cleanest to do that here, all in one place.
+ * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
+ * cast away constness, and it is cleanest to do that here, all in one place.
*
* int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes,
* int length);
*/
#define TclRegisterNewLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)
+ TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)
/*
- * Form of TclRegisterNSLiteral with onHeap == 0. In that case, it is safe to
- * cast away CONSTness, and it is cleanest to do that here, all in one place.
+ * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it
+ * is safe to cast away constness, and it is cleanest to do that here, all in
+ * one place.
*
* int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
* int length);
*/
-#define TclRegisterNewNSLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, \
- /*flags*/ LITERAL_NS_SCOPE)
+#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
+ TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
/*
* Macro used to manually adjust the stack requirements; used in cases where
@@ -1003,12 +1024,14 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclAdjustStackDepth(delta, envPtr) \
- if ((delta) < 0) {\
- if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
- (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
- }\
- }\
- (envPtr)->currStackDepth += (delta)
+ do { \
+ if ((delta) < 0) { \
+ if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \
+ (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \
+ } \
+ } \
+ (envPtr)->currStackDepth += (delta); \
+ } while (0)
/*
* Macro used to update the stack requirements. It is called by the macros
@@ -1021,15 +1044,15 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclUpdateStackReqs(op, i, envPtr) \
- {\
- int delta = tclInstructionTable[(op)].stackEffect;\
- if (delta) {\
- if (delta == INT_MIN) {\
- delta = 1 - (i);\
- }\
- TclAdjustStackDepth(delta, envPtr);\
- }\
- }
+ do { \
+ int delta = tclInstructionTable[(op)].stackEffect; \
+ if (delta) { \
+ if (delta == INT_MIN) { \
+ delta = 1 - (i); \
+ } \
+ TclAdjustStackDepth(delta, envPtr); \
+ } \
+ } while (0)
/*
* Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C
@@ -1039,12 +1062,14 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclEmitOpcode(op, envPtr) \
- if ((envPtr)->codeNext == (envPtr)->codeEnd) { \
- TclExpandCodeArray(envPtr); \
- } \
- *(envPtr)->codeNext++ = (unsigned char) (op);\
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
- TclUpdateStackReqs(op, 0, envPtr)
+ do { \
+ if ((envPtr)->codeNext == (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
+ *(envPtr)->codeNext++ = (unsigned char) (op); \
+ (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateStackReqs(op, 0, envPtr); \
+ } while (0)
/*
* Macros to emit an integer operand. The ANSI C "prototype" for these macros
@@ -1055,23 +1080,27 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclEmitInt1(i, envPtr) \
- if ((envPtr)->codeNext == (envPtr)->codeEnd) { \
- TclExpandCodeArray(envPtr); \
- } \
- *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
+ do { \
+ if ((envPtr)->codeNext == (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
+ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
+ } while (0)
#define TclEmitInt4(i, envPtr) \
- if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \
- TclExpandCodeArray(envPtr); \
- } \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 24); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 16); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 8); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) )
+ do { \
+ if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 24); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 16); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 8); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) ); \
+ } while (0)
/*
* Macros to emit an instruction with signed or unsigned integer operands.
@@ -1084,29 +1113,33 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclEmitInstInt1(op, i, envPtr) \
- if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
- TclExpandCodeArray(envPtr); \
- } \
- *(envPtr)->codeNext++ = (unsigned char) (op); \
- *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
- TclUpdateStackReqs(op, i, envPtr)
+ do { \
+ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
+ *(envPtr)->codeNext++ = (unsigned char) (op); \
+ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
+ (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateStackReqs(op, i, envPtr); \
+ } while (0)
#define TclEmitInstInt4(op, i, envPtr) \
- if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
- TclExpandCodeArray(envPtr); \
- } \
- *(envPtr)->codeNext++ = (unsigned char) (op); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 24); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 16); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 8); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) );\
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
- TclUpdateStackReqs(op, i, envPtr)
+ do { \
+ if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
+ *(envPtr)->codeNext++ = (unsigned char) (op); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 24); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 16); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) >> 8); \
+ *(envPtr)->codeNext++ = \
+ (unsigned char) ((unsigned int) (i) ); \
+ (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateStackReqs(op, i, envPtr); \
+ } while (0)
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
@@ -1118,14 +1151,14 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclEmitPush(objIndex, envPtr) \
- {\
- register int objIndexCopy = (objIndex);\
- if (objIndexCopy <= 255) { \
+ do { \
+ register int objIndexCopy = (objIndex); \
+ if (objIndexCopy <= 255) { \
TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
- } else { \
+ } else { \
TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
- }\
- }
+ } \
+ } while (0)
/*
* Macros to update a (signed or unsigned) integer starting at a pointer. The
@@ -1140,10 +1173,12 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*(p) = (unsigned char) ((unsigned int) (i))
#define TclStoreInt4AtPtr(i, p) \
- *(p) = (unsigned char) ((unsigned int) (i) >> 24); \
- *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
- *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
- *(p+3) = (unsigned char) ((unsigned int) (i) )
+ do { \
+ *(p) = (unsigned char) ((unsigned int) (i) >> 24); \
+ *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
+ *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
+ *(p+3) = (unsigned char) ((unsigned int) (i) ); \
+ } while (0)
/*
* Macros to update instructions at a particular pc with a new op code and a
@@ -1155,12 +1190,16 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclUpdateInstInt1AtPc(op, i, pc) \
- *(pc) = (unsigned char) (op); \
- TclStoreInt1AtPtr((i), ((pc)+1))
+ do { \
+ *(pc) = (unsigned char) (op); \
+ TclStoreInt1AtPtr((i), ((pc)+1)); \
+ } while (0)
#define TclUpdateInstInt4AtPc(op, i, pc) \
- *(pc) = (unsigned char) (op); \
- TclStoreInt4AtPtr((i), ((pc)+1))
+ do { \
+ *(pc) = (unsigned char) (op); \
+ TclStoreInt4AtPtr((i), ((pc)+1)); \
+ } while (0)
/*
* Macro to fix up a forward jump to point to the current code-generation
@@ -1172,7 +1211,7 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
*/
#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \
- TclFixupForwardJump((envPtr), (fixupPtr), \
+ TclFixupForwardJump((envPtr), (fixupPtr), \
(envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \
(threshold))
@@ -1198,25 +1237,26 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
#ifndef __CHAR_UNSIGNED__
# define TclGetInt1AtPtr(p) ((int) *((char *) p))
+#elif defined(HAVE_SIGNED_CHAR)
+# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#else
-# ifdef HAVE_SIGNED_CHAR
-# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
-# else
-# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
- | ((*(p) & 0200) ? (-256) : 0))
-# endif
+# define TclGetInt1AtPtr(p) \
+ (((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0))
#endif
-#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
- (*((p)+1) << 16) | \
- (*((p)+2) << 8) | \
- (*((p)+3)))
+#define TclGetInt4AtPtr(p) \
+ (((int) TclGetInt1AtPtr(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
-#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
-#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \
- (*((p)+1) << 16) | \
- (*((p)+2) << 8) | \
- (*((p)+3)))
+#define TclGetUInt1AtPtr(p) \
+ ((unsigned int) *(p))
+#define TclGetUInt4AtPtr(p) \
+ ((unsigned int) (*(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
/*
* Macros used to compute the minimum and maximum of two integers. The ANSI C
@@ -1226,8 +1266,96 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
* int TclMax(int i, int j);
*/
-#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j))
-#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
+#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j))
+#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:
+ *
+ * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp);
+ */
+
+#define CompileBody(envPtr, tokenPtr, interp) \
+ TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr))
+
+/*
+ * Convenience macro for use when compiling tokens to be pushed. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp);
+ */
+
+#define CompileTokens(envPtr, tokenPtr, interp) \
+ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr));
+/*
+ * Convenience macro for use when pushing literals. The ANSI C "prototype" for
+ * this macro is:
+ *
+ * static void PushLiteral(CompileEnv *envPtr,
+ * const char *string, int length);
+ */
+
+#define PushLiteral(envPtr, string, length) \
+ TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+
+/*
+ * Macro to advance to the next token; it is more mnemonic than the address
+ * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
+ *
+ * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
+ */
+
+#define TokenAfter(tokenPtr) \
+ ((tokenPtr) + ((tokenPtr)->numComponents + 1))
+
+/*
+ * Macro to get the offset to the next instruction to be issued. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * static int CurrentOffset(CompileEnv *envPtr);
+ */
+
+#define CurrentOffset(envPtr) \
+ ((envPtr)->codeNext - (envPtr)->codeStart)
+
+/*
+ * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
+ * maximal depth of nested CATCH ranges in order to alloc runtime
+ * memory. These macros should compute precisely that? OTOH, the nesting depth
+ * 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 = \
+ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
+ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
+#define ExceptionRangeEnds(envPtr, index) \
+ (((envPtr)->exceptDepth--), \
+ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
+ CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
+#define ExceptionRangeTarget(envPtr, index, targetType) \
+ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
+
+/*
+ * Check if there is an LVT for compiled locals
+ */
+
+#define EnvHasLVT(envPtr) \
+ (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr)
/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
@@ -1241,7 +1369,7 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
* If the second macro is defined, logging to file starts immediately,
* otherwise only after the first call to [tcl::dtrace]. Note that the debug
* probe data is always computed, even when it is not logged to file.
- *
+ *
* Defining the third macro enables debug logging of inst probes (disabled
* by default due to the significant performance impact).
*/
@@ -1256,10 +1384,10 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
#ifdef USE_DTRACE
-#include "tclDTrace.h"
-
#if defined(__GNUC__) && __GNUC__ > 2
-/* Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. */
+/*
+ * Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks.
+ */
#define unlikely(x) (__builtin_expect((x), 0))
#else
#define unlikely(x) (x)
@@ -1275,8 +1403,8 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3)
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
-#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) \
- TCL_PROC_INFO(a0, a1, a2, a3, a4, a5)
+#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
+ TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7)
#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED())
#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED())
@@ -1288,8 +1416,8 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3)
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
-#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) \
- TCL_CMD_INFO(a0, a1, a2, a3, a4, a5)
+#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
+ TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7)
#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED())
#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED())
@@ -1302,7 +1430,8 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
#define TCL_DTRACE_DEBUG_LOG()
-MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
+MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args,
+ int *argsi);
#else /* USE_DTRACE */
@@ -1311,11 +1440,11 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_PROC_RESULT_ENABLED() 0
#define TCL_DTRACE_PROC_ARGS_ENABLED() 0
#define TCL_DTRACE_PROC_INFO_ENABLED() 0
-#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {}
-#define TCL_DTRACE_PROC_RETURN(a0, a1) {}
-#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {}
+#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}}
+#define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}}
+#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}}
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
-#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) {}
+#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {}
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0
#define TCL_DTRACE_CMD_RETURN_ENABLED() 0
@@ -1326,7 +1455,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_CMD_RETURN(a0, a1) {}
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {}
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
-#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) {}
+#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {}
#define TCL_DTRACE_INST_START_ENABLED() 0
#define TCL_DTRACE_INST_DONE_ENABLED() 0
@@ -1357,27 +1486,36 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent;
MODULE_SCOPE FILE *tclDTraceDebugLog;
MODULE_SCOPE void TclDTraceOpenDebugLog(void);
-MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
+MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi);
#define TCL_DTRACE_DEBUG_LOG() \
- int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED;\
- int tclDTraceDebugIndent = 0; \
- FILE *tclDTraceDebugLog = NULL; \
- void TclDTraceOpenDebugLog(void) { char n[35]; \
- sprintf(n, "/tmp/tclDTraceDebug-%lu.log", (unsigned long) getpid()); \
- tclDTraceDebugLog = fopen(n, "a"); } \
-
-#define TclDTraceDbgMsg(p, m, ...) do { if (tclDTraceDebugEnabled) { \
- int _l, _t = 0; if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \
- fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", strrchr(__FILE__, '/') + \
- 1, __LINE__, &_l); _t += _l; \
- fprintf(tclDTraceDebugLog, " %.*s():%n", (_t < 18 ? 18 - _t : 0) + \
- 18, __func__, &_l); _t += _l; \
- fprintf(tclDTraceDebugLog, "%*s" p "%n", (_t < 40 ? 40 - _t : 0) + \
- 2 * tclDTraceDebugIndent, "", &_l); _t += _l; \
- fprintf(tclDTraceDebugLog, "%*s" m "\n", (_t < 64 ? 64 - _t : 1), "", \
- ##__VA_ARGS__); fflush(tclDTraceDebugLog); \
- } } while (0)
+ int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \
+ int tclDTraceDebugIndent = 0; \
+ FILE *tclDTraceDebugLog = NULL; \
+ void TclDTraceOpenDebugLog(void) { \
+ char n[35]; \
+ sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \
+ (unsigned long) getpid()); \
+ tclDTraceDebugLog = fopen(n, "a"); \
+ }
+
+#define TclDTraceDbgMsg(p, m, ...) \
+ do { \
+ if (tclDTraceDebugEnabled) { \
+ int _l, _t = 0; \
+ if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \
+ fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \
+ strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \
+ fprintf(tclDTraceDebugLog, " %.*s():%n", \
+ (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \
+ fprintf(tclDTraceDebugLog, "%*s" p "%n", \
+ (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \
+ "", &_l); _t += _l; \
+ fprintf(tclDTraceDebugLog, "%*s" m "\n", \
+ (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \
+ fflush(tclDTraceDebugLog); \
+ } \
+ } while (0)
#define TCL_DTRACE_PROC_ENTRY_ENABLED() 1
#define TCL_DTRACE_PROC_RETURN_ENABLED() 1
@@ -1395,9 +1533,9 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
a1, a2, a3, a4, a5, a6, a7, a8, a9)
-#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) \
- TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d", a0, a1, \
- a2, a3, a4, a5)
+#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
+ TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \
+ a2, a3, a4, a5, a6, a7)
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 1
#define TCL_DTRACE_CMD_RETURN_ENABLED() 1
@@ -1415,9 +1553,9 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
a1, a2, a3, a4, a5, a6, a7, a8, a9)
-#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) \
- TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d", a0, a1, \
- a2, a3, a4, a5)
+#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
+ TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \
+ a2, a3, a4, a5, a6, a7)
#define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
#define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
@@ -1428,9 +1566,11 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_TCL_PROBE_ENABLED() 1
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
- tclDTraceDebugEnabled = 1; \
+ do { \
+ tclDTraceDebugEnabled = 1; \
TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \
- a1, a2, a3, a4, a5, a6, a7, a8, a9)
+ a1, a2, a3, a4, a5, a6, a7, a8, a9); \
+ } while (0)
#endif /* TCL_DTRACE_DEBUG */
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 251868e..b4735e8 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -42,7 +42,7 @@ typedef struct QCCD {
static int QueryConfigObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- struct Tcl_Obj *CONST *objv);
+ struct Tcl_Obj *const *objv);
static void QueryConfigDelete(ClientData clientData);
static Tcl_Obj * GetConfigDict(Tcl_Interp *interp);
static void ConfigDictDeleteProc(ClientData clientData,
@@ -68,18 +68,17 @@ void
Tcl_RegisterConfig(
Tcl_Interp *interp, /* Interpreter the configuration command is
* registered in. */
- CONST char *pkgName, /* Name of the package registering the
+ const char *pkgName, /* Name of the package registering the
* embedded configuration. ASCII, thus in
* UTF-8 too. */
- Tcl_Config *configuration, /* Embedded configuration. */
- CONST char *valEncoding) /* Name of the encoding used to store the
+ const Tcl_Config *configuration, /* Embedded configuration. */
+ const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
- Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
- Tcl_Config *cfg;
+ const Tcl_Config *cfg;
Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
- QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));
+ QCCD *cdPtr = ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
@@ -105,14 +104,14 @@ Tcl_RegisterConfig(
*/
if (venc != NULL) {
+ Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp);
+
/*
* Retrieve package specific configuration...
*/
- pDB = GetConfigDict(interp);
-
if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
- || (pkgDict == NULL)) {
+ || (pkgDict == NULL)) {
pkgDict = Tcl_NewDictObj();
} else if (Tcl_IsShared(pkgDict)) {
pkgDict = Tcl_DuplicateObj(pkgDict);
@@ -124,8 +123,8 @@ Tcl_RegisterConfig(
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
Tcl_DString conv;
- CONST char *convValue =
- Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
+ const char *convValue =
+ Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
/*
* We know that the keys are in ASCII/UTF-8, so for them is no
@@ -133,7 +132,7 @@ Tcl_RegisterConfig(
*/
Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
- Tcl_NewStringObj(convValue, -1));
+ Tcl_NewStringObj(convValue, -1));
Tcl_DStringFree(&conv);
}
@@ -177,8 +176,8 @@ Tcl_RegisterConfig(
Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
- QueryConfigObjCmd, (ClientData) cdPtr, QueryConfigDelete) == NULL) {
- Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
+ QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
+ Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
"Unable to create query command for package configuration");
}
@@ -207,13 +206,13 @@ QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
- struct Tcl_Obj *CONST *objv)
+ struct Tcl_Obj *const *objv)
{
- QCCD *cdPtr = (QCCD *) clientData;
+ QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
- static CONST char *subcmdStrings[] = {
+ static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
@@ -221,7 +220,7 @@ QueryConfigObjCmd(
};
if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
@@ -232,12 +231,14 @@ QueryConfigObjCmd(
pDB = GetConfigDict(interp);
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
- /*
+ /*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
- Tcl_SetResult(interp, "package not known", TCL_STATIC);
+ Tcl_SetResult(interp, "package not known", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
+ Tcl_GetString(pkgName), NULL);
return TCL_ERROR;
}
@@ -248,9 +249,11 @@ QueryConfigObjCmd(
return TCL_ERROR;
}
- if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK
+ if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetResult(interp, "key not known", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
+ Tcl_GetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -269,6 +272,7 @@ QueryConfigObjCmd(
if (!listPtr) {
Tcl_SetResult(interp, "insufficient memory to create list",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
@@ -314,12 +318,13 @@ static void
QueryConfigDelete(
ClientData clientData)
{
- QCCD *cdPtr = (QCCD *) clientData;
+ QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
+
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
- ckfree((char *)cdPtr);
+ ckfree(cdPtr);
}
/*
@@ -378,7 +383,7 @@ ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
- Tcl_Obj *pDB = (Tcl_Obj *) clientData;
+ Tcl_Obj *pDB = clientData;
Tcl_DecrRefCount(pDB);
}
diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d
index bdbcb6e..0ee592f 100644
--- a/generic/tclDTrace.d
+++ b/generic/tclDTrace.d
@@ -3,13 +3,14 @@
*
* Tcl DTrace provider.
*
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
typedef struct Tcl_Obj Tcl_Obj;
+typedef const char* TclDTraceStr;
/*
* Tcl DTrace probes
@@ -24,14 +25,14 @@ provider tcl {
* arg1: number of arguments (int)
* arg2: array of proc argument objects (Tcl_Obj**)
*/
- probe proc__entry(char* name, int objc, Tcl_Obj **objv);
+ probe proc__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
/*
* tcl*:::proc-return probe
* triggered immediately after proc bytecode execution
* arg0: proc name (string)
* arg1: return code (int)
*/
- probe proc__return(char* name, int code);
+ probe proc__return(TclDTraceStr name, int code);
/*
* tcl*:::proc-result probe
* triggered after proc-return probe and result processing
@@ -40,7 +41,8 @@ provider tcl {
* arg2: proc result (string)
* arg3: proc result object (Tcl_Obj*)
*/
- probe proc__result(char* name, int code, char* result, Tcl_Obj *resultobj);
+ probe proc__result(TclDTraceStr name, int code, TclDTraceStr result,
+ Tcl_Obj *resultobj);
/*
* tcl*:::proc-args probe
* triggered before proc-entry probe, gives access to string
@@ -48,9 +50,10 @@ provider tcl {
* arg0: proc name (string)
* arg1-arg9: proc arguments or NULL (strings)
*/
- probe proc__args(char* name, char* arg1, char* arg2, char* arg3,
- char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
- char* arg9);
+ probe proc__args(TclDTraceStr name, TclDTraceStr arg1, TclDTraceStr arg2,
+ TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5,
+ TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8,
+ TclDTraceStr arg9);
/*
* tcl*:::proc-info probe
* triggered before proc-entry probe, gives access to TIP 280
@@ -61,9 +64,12 @@ provider tcl {
* arg3: TIP 280 file (string)
* arg4: TIP 280 line (int)
* arg5: TIP 280 level (int)
+ * arg6: TclOO method (string)
+ * arg7: TclOO class/object (string)
*/
- probe proc__info(char* cmd, char* type, char* proc, char* file, int line,
- int level);
+ probe proc__info(TclDTraceStr cmd, TclDTraceStr type, TclDTraceStr proc,
+ TclDTraceStr file, int line, int level, TclDTraceStr method,
+ TclDTraceStr class);
/***************************** cmd probes ******************************/
/*
@@ -73,14 +79,14 @@ provider tcl {
* arg1: number of arguments (int)
* arg2: array of command argument objects (Tcl_Obj**)
*/
- probe cmd__entry(char* name, int objc, Tcl_Obj **objv);
+ probe cmd__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
/*
* tcl*:::cmd-return probe
* triggered immediately after commmand execution
* arg0: command name (string)
* arg1: return code (int)
*/
- probe cmd__return(char* name, int code);
+ probe cmd__return(TclDTraceStr name, int code);
/*
* tcl*:::cmd-result probe
* triggered after cmd-return probe and result processing
@@ -89,7 +95,8 @@ provider tcl {
* arg2: command result (string)
* arg3: command result object (Tcl_Obj*)
*/
- probe cmd__result(char* name, int code, char* result, Tcl_Obj *resultobj);
+ probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result,
+ Tcl_Obj *resultobj);
/*
* tcl*:::cmd-args probe
* triggered before cmd-entry probe, gives access to string
@@ -97,9 +104,10 @@ provider tcl {
* arg0: command name (string)
* arg1-arg9: command arguments or NULL (strings)
*/
- probe cmd__args(char* name, char* arg1, char* arg2, char* arg3,
- char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
- char* arg9);
+ probe cmd__args(TclDTraceStr name, TclDTraceStr arg1, TclDTraceStr arg2,
+ TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5,
+ TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8,
+ TclDTraceStr arg9);
/*
* tcl*:::cmd-info probe
* triggered before cmd-entry probe, gives access to TIP 280
@@ -110,9 +118,12 @@ provider tcl {
* arg3: TIP 280 file (string)
* arg4: TIP 280 line (int)
* arg5: TIP 280 level (int)
+ * arg6: TclOO method (string)
+ * arg7: TclOO class/object (string)
*/
- probe cmd__info(char* cmd, char* type, char* proc, char* file, int line,
- int level);
+ probe cmd__info(TclDTraceStr cmd, TclDTraceStr type, TclDTraceStr proc,
+ TclDTraceStr file, int line, int level, TclDTraceStr method,
+ TclDTraceStr class);
/***************************** inst probes *****************************/
/*
@@ -122,7 +133,7 @@ provider tcl {
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
- probe inst__start(char* name, int depth, Tcl_Obj **stack);
+ probe inst__start(TclDTraceStr name, int depth, Tcl_Obj **stack);
/*
* tcl*:::inst-done probe
* triggered immediately after execution of a bytecode
@@ -130,7 +141,7 @@ provider tcl {
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
- probe inst__done(char* name, int depth, Tcl_Obj **stack);
+ probe inst__done(TclDTraceStr name, int depth, Tcl_Obj **stack);
/***************************** obj probes ******************************/
/*
@@ -152,9 +163,10 @@ provider tcl {
* triggered when the ::tcl::dtrace command is called
* arg0-arg9: command arguments (strings)
*/
- probe tcl__probe(char* arg0, char* arg1, char* arg2, char* arg3,
- char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
- char* arg9);
+ probe tcl__probe(TclDTraceStr arg0, TclDTraceStr arg1, TclDTraceStr arg2,
+ TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5,
+ TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8,
+ TclDTraceStr arg9);
};
/*
diff --git a/generic/tclDate.c b/generic/tclDate.c
index b77c7fd..14bac51 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2291,15 +2291,11 @@ yyreturn:
-MODULE_SCOPE int yychar;
-MODULE_SCOPE YYSTYPE yylval;
-MODULE_SCOPE int yynerrs;
-
/*
* Month and day table.
*/
-static TABLE MonthDayTable[] = {
+static const TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
@@ -2324,14 +2320,14 @@ static TABLE MonthDayTable[] = {
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Time units table.
*/
-static TABLE UnitsTable[] = {
+static const TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
@@ -2342,14 +2338,14 @@ static TABLE UnitsTable[] = {
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Assorted relative-time words.
*/
-static TABLE OtherTable[] = {
+static const TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
@@ -2374,7 +2370,7 @@ static TABLE OtherTable[] = {
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
@@ -2382,7 +2378,7 @@ static TABLE OtherTable[] = {
* point constants to work around an SGI compiler bug).
*/
-static TABLE TimezoneTable[] = {
+static const TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
@@ -2460,14 +2456,14 @@ static TABLE TimezoneTable[] = {
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Military timezone table.
*/
-static TABLE MilitaryTable[] = {
+static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) },
{ "b", tZONE, -HOUR( 2) },
{ "c", tZONE, -HOUR( 3) },
@@ -2493,7 +2489,7 @@ static TABLE MilitaryTable[] = {
{ "x", tZONE, HOUR( 11) },
{ "y", tZONE, HOUR( 12) },
{ "z", tZONE, HOUR( 0) },
- { NULL }
+ { NULL, 0, 0 }
};
/*
@@ -2560,7 +2556,7 @@ LookupWord(
{
register char *p;
register char *q;
- register TABLE *tp;
+ register const TABLE *tp;
int i, abbrev;
/*
@@ -2756,7 +2752,7 @@ TclClockOldscanObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
- Tcl_Obj *CONST *objv) /* Parameters */
+ Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
@@ -2804,10 +2800,12 @@ TclClockOldscanObjCmd(
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
return TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
@@ -2815,6 +2813,7 @@ TclClockOldscanObjCmd(
"report this error as a "
"bug in Tcl.", -1));
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
return TCL_ERROR;
}
Tcl_DecrRefCount(dateInfo.messages);
@@ -2822,26 +2821,31 @@ TclClockOldscanObjCmd(
if (yyHaveDate > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one date in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveTime > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time of day in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveZone > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time zone in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveDay > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one weekday in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index b741475..f83bff7 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -35,3404 +35,1803 @@
* Exported function declarations:
*/
-#ifndef Tcl_PkgProvideEx_TCL_DECLARED
-#define Tcl_PkgProvideEx_TCL_DECLARED
/* 0 */
EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp,
- CONST char *name, CONST char *version,
- ClientData clientData);
-#endif
-#ifndef Tcl_PkgRequireEx_TCL_DECLARED
-#define Tcl_PkgRequireEx_TCL_DECLARED
+ const char *name, const char *version,
+ const void *clientData);
/* 1 */
EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp,
- CONST char *name, CONST char *version,
- int exact, ClientData *clientDataPtr);
-#endif
-#ifndef Tcl_Panic_TCL_DECLARED
-#define Tcl_Panic_TCL_DECLARED
+ const char *name, const char *version,
+ int exact, void *clientDataPtr);
/* 2 */
-EXTERN void Tcl_Panic(CONST char *format, ...);
-#endif
-#ifndef Tcl_Alloc_TCL_DECLARED
-#define Tcl_Alloc_TCL_DECLARED
+EXTERN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
/* 3 */
EXTERN char * Tcl_Alloc(unsigned int size);
-#endif
-#ifndef Tcl_Free_TCL_DECLARED
-#define Tcl_Free_TCL_DECLARED
/* 4 */
EXTERN void Tcl_Free(char *ptr);
-#endif
-#ifndef Tcl_Realloc_TCL_DECLARED
-#define Tcl_Realloc_TCL_DECLARED
/* 5 */
EXTERN char * Tcl_Realloc(char *ptr, unsigned int size);
-#endif
-#ifndef Tcl_DbCkalloc_TCL_DECLARED
-#define Tcl_DbCkalloc_TCL_DECLARED
/* 6 */
-EXTERN char * Tcl_DbCkalloc(unsigned int size, CONST char *file,
+EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file,
int line);
-#endif
-#ifndef Tcl_DbCkfree_TCL_DECLARED
-#define Tcl_DbCkfree_TCL_DECLARED
/* 7 */
-EXTERN int Tcl_DbCkfree(char *ptr, CONST char *file, int line);
-#endif
-#ifndef Tcl_DbCkrealloc_TCL_DECLARED
-#define Tcl_DbCkrealloc_TCL_DECLARED
+EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line);
/* 8 */
EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size,
- CONST char *file, int line);
-#endif
+ const char *file, int line);
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_CreateFileHandler_TCL_DECLARED
-#define Tcl_CreateFileHandler_TCL_DECLARED
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
Tcl_FileProc *proc, ClientData clientData);
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_CreateFileHandler_TCL_DECLARED
-#define Tcl_CreateFileHandler_TCL_DECLARED
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
Tcl_FileProc *proc, ClientData clientData);
-#endif
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_DeleteFileHandler_TCL_DECLARED
-#define Tcl_DeleteFileHandler_TCL_DECLARED
/* 10 */
EXTERN void Tcl_DeleteFileHandler(int fd);
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_DeleteFileHandler_TCL_DECLARED
-#define Tcl_DeleteFileHandler_TCL_DECLARED
/* 10 */
EXTERN void Tcl_DeleteFileHandler(int fd);
-#endif
#endif /* MACOSX */
-#ifndef Tcl_SetTimer_TCL_DECLARED
-#define Tcl_SetTimer_TCL_DECLARED
/* 11 */
-EXTERN void Tcl_SetTimer(Tcl_Time *timePtr);
-#endif
-#ifndef Tcl_Sleep_TCL_DECLARED
-#define Tcl_Sleep_TCL_DECLARED
+EXTERN void Tcl_SetTimer(const Tcl_Time *timePtr);
/* 12 */
EXTERN void Tcl_Sleep(int ms);
-#endif
-#ifndef Tcl_WaitForEvent_TCL_DECLARED
-#define Tcl_WaitForEvent_TCL_DECLARED
/* 13 */
-EXTERN int Tcl_WaitForEvent(Tcl_Time *timePtr);
-#endif
-#ifndef Tcl_AppendAllObjTypes_TCL_DECLARED
-#define Tcl_AppendAllObjTypes_TCL_DECLARED
+EXTERN int Tcl_WaitForEvent(const Tcl_Time *timePtr);
/* 14 */
EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
-#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...);
-#endif
-#ifndef Tcl_AppendToObj_TCL_DECLARED
-#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
-EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, CONST char *bytes,
+EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes,
int length);
-#endif
-#ifndef Tcl_ConcatObj_TCL_DECLARED
-#define Tcl_ConcatObj_TCL_DECLARED
/* 17 */
-EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_ConvertToType_TCL_DECLARED
-#define Tcl_ConvertToType_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]);
/* 18 */
EXTERN int Tcl_ConvertToType(Tcl_Interp *interp,
- Tcl_Obj *objPtr, Tcl_ObjType *typePtr);
-#endif
-#ifndef Tcl_DbDecrRefCount_TCL_DECLARED
-#define Tcl_DbDecrRefCount_TCL_DECLARED
+ Tcl_Obj *objPtr, const Tcl_ObjType *typePtr);
/* 19 */
-EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file,
+EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file,
int line);
-#endif
-#ifndef Tcl_DbIncrRefCount_TCL_DECLARED
-#define Tcl_DbIncrRefCount_TCL_DECLARED
/* 20 */
-EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file,
+EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
int line);
-#endif
-#ifndef Tcl_DbIsShared_TCL_DECLARED
-#define Tcl_DbIsShared_TCL_DECLARED
/* 21 */
-EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, CONST char *file,
+EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
-#endif
-#ifndef Tcl_DbNewBooleanObj_TCL_DECLARED
-#define Tcl_DbNewBooleanObj_TCL_DECLARED
/* 22 */
-EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, CONST char *file,
+EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file,
int line);
-#endif
-#ifndef Tcl_DbNewByteArrayObj_TCL_DECLARED
-#define Tcl_DbNewByteArrayObj_TCL_DECLARED
/* 23 */
-EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes,
- int length, CONST char *file, int line);
-#endif
-#ifndef Tcl_DbNewDoubleObj_TCL_DECLARED
-#define Tcl_DbNewDoubleObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
+ int length, const char *file, int line);
/* 24 */
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_DbNewListObj_TCL_DECLARED
-#define Tcl_DbNewListObj_TCL_DECLARED
+ const char *file, int line);
/* 25 */
-EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_DbNewLongObj_TCL_DECLARED
-#define Tcl_DbNewLongObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
+ const char *file, int line);
/* 26 */
-EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, CONST char *file,
+EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
int line);
-#endif
-#ifndef Tcl_DbNewObj_TCL_DECLARED
-#define Tcl_DbNewObj_TCL_DECLARED
/* 27 */
-EXTERN Tcl_Obj * Tcl_DbNewObj(CONST char *file, int line);
-#endif
-#ifndef Tcl_DbNewStringObj_TCL_DECLARED
-#define Tcl_DbNewStringObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line);
/* 28 */
-EXTERN Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_DuplicateObj_TCL_DECLARED
-#define Tcl_DuplicateObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length,
+ const char *file, int line);
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr);
-#endif
-#ifndef TclFreeObj_TCL_DECLARED
-#define TclFreeObj_TCL_DECLARED
/* 30 */
EXTERN void TclFreeObj(Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetBoolean_TCL_DECLARED
-#define Tcl_GetBoolean_TCL_DECLARED
/* 31 */
-EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src,
+EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src,
int *boolPtr);
-#endif
-#ifndef Tcl_GetBooleanFromObj_TCL_DECLARED
-#define Tcl_GetBooleanFromObj_TCL_DECLARED
/* 32 */
EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *boolPtr);
-#endif
-#ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED
-#define Tcl_GetByteArrayFromObj_TCL_DECLARED
/* 33 */
EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
-#endif
-#ifndef Tcl_GetDouble_TCL_DECLARED
-#define Tcl_GetDouble_TCL_DECLARED
/* 34 */
-EXTERN int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src,
+EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
double *doublePtr);
-#endif
-#ifndef Tcl_GetDoubleFromObj_TCL_DECLARED
-#define Tcl_GetDoubleFromObj_TCL_DECLARED
/* 35 */
EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
-#endif
-#ifndef Tcl_GetIndexFromObj_TCL_DECLARED
-#define Tcl_GetIndexFromObj_TCL_DECLARED
/* 36 */
EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr, CONST84 char **tablePtr,
- CONST char *msg, int flags, int *indexPtr);
-#endif
-#ifndef Tcl_GetInt_TCL_DECLARED
-#define Tcl_GetInt_TCL_DECLARED
+ Tcl_Obj *objPtr,
+ CONST84 char *const *tablePtr,
+ const char *msg, int flags, int *indexPtr);
/* 37 */
-EXTERN int Tcl_GetInt(Tcl_Interp *interp, CONST char *src,
+EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
int *intPtr);
-#endif
-#ifndef Tcl_GetIntFromObj_TCL_DECLARED
-#define Tcl_GetIntFromObj_TCL_DECLARED
/* 38 */
EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *intPtr);
-#endif
-#ifndef Tcl_GetLongFromObj_TCL_DECLARED
-#define Tcl_GetLongFromObj_TCL_DECLARED
/* 39 */
EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, long *longPtr);
-#endif
-#ifndef Tcl_GetObjType_TCL_DECLARED
-#define Tcl_GetObjType_TCL_DECLARED
/* 40 */
-EXTERN Tcl_ObjType * Tcl_GetObjType(CONST char *typeName);
-#endif
-#ifndef Tcl_GetStringFromObj_TCL_DECLARED
-#define Tcl_GetStringFromObj_TCL_DECLARED
+EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName);
/* 41 */
EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr);
-#endif
-#ifndef Tcl_InvalidateStringRep_TCL_DECLARED
-#define Tcl_InvalidateStringRep_TCL_DECLARED
/* 42 */
EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_ListObjAppendList_TCL_DECLARED
-#define Tcl_ListObjAppendList_TCL_DECLARED
/* 43 */
EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *elemListPtr);
-#endif
-#ifndef Tcl_ListObjAppendElement_TCL_DECLARED
-#define Tcl_ListObjAppendElement_TCL_DECLARED
/* 44 */
EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_ListObjGetElements_TCL_DECLARED
-#define Tcl_ListObjGetElements_TCL_DECLARED
/* 45 */
EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp,
Tcl_Obj *listPtr, int *objcPtr,
Tcl_Obj ***objvPtr);
-#endif
-#ifndef Tcl_ListObjIndex_TCL_DECLARED
-#define Tcl_ListObjIndex_TCL_DECLARED
/* 46 */
EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj **objPtrPtr);
-#endif
-#ifndef Tcl_ListObjLength_TCL_DECLARED
-#define Tcl_ListObjLength_TCL_DECLARED
/* 47 */
EXTERN int Tcl_ListObjLength(Tcl_Interp *interp,
Tcl_Obj *listPtr, int *lengthPtr);
-#endif
-#ifndef Tcl_ListObjReplace_TCL_DECLARED
-#define Tcl_ListObjReplace_TCL_DECLARED
/* 48 */
EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
Tcl_Obj *listPtr, int first, int count,
- int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_NewBooleanObj_TCL_DECLARED
-#define Tcl_NewBooleanObj_TCL_DECLARED
+ int objc, Tcl_Obj *const objv[]);
/* 49 */
EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
-#endif
-#ifndef Tcl_NewByteArrayObj_TCL_DECLARED
-#define Tcl_NewByteArrayObj_TCL_DECLARED
/* 50 */
-EXTERN Tcl_Obj * Tcl_NewByteArrayObj(CONST unsigned char *bytes,
+EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
int length);
-#endif
-#ifndef Tcl_NewDoubleObj_TCL_DECLARED
-#define Tcl_NewDoubleObj_TCL_DECLARED
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue);
-#endif
-#ifndef Tcl_NewIntObj_TCL_DECLARED
-#define Tcl_NewIntObj_TCL_DECLARED
/* 52 */
EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue);
-#endif
-#ifndef Tcl_NewListObj_TCL_DECLARED
-#define Tcl_NewListObj_TCL_DECLARED
/* 53 */
-EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_NewLongObj_TCL_DECLARED
-#define Tcl_NewLongObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
/* 54 */
EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue);
-#endif
-#ifndef Tcl_NewObj_TCL_DECLARED
-#define Tcl_NewObj_TCL_DECLARED
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj(void);
-#endif
-#ifndef Tcl_NewStringObj_TCL_DECLARED
-#define Tcl_NewStringObj_TCL_DECLARED
/* 56 */
-EXTERN Tcl_Obj * Tcl_NewStringObj(CONST char *bytes, int length);
-#endif
-#ifndef Tcl_SetBooleanObj_TCL_DECLARED
-#define Tcl_SetBooleanObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length);
/* 57 */
EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
-#endif
-#ifndef Tcl_SetByteArrayLength_TCL_DECLARED
-#define Tcl_SetByteArrayLength_TCL_DECLARED
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length);
-#endif
-#ifndef Tcl_SetByteArrayObj_TCL_DECLARED
-#define Tcl_SetByteArrayObj_TCL_DECLARED
/* 59 */
EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
- CONST unsigned char *bytes, int length);
-#endif
-#ifndef Tcl_SetDoubleObj_TCL_DECLARED
-#define Tcl_SetDoubleObj_TCL_DECLARED
+ const unsigned char *bytes, int length);
/* 60 */
EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
-#endif
-#ifndef Tcl_SetIntObj_TCL_DECLARED
-#define Tcl_SetIntObj_TCL_DECLARED
/* 61 */
EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
-#endif
-#ifndef Tcl_SetListObj_TCL_DECLARED
-#define Tcl_SetListObj_TCL_DECLARED
/* 62 */
EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_SetLongObj_TCL_DECLARED
-#define Tcl_SetLongObj_TCL_DECLARED
+ Tcl_Obj *const objv[]);
/* 63 */
EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
-#endif
-#ifndef Tcl_SetObjLength_TCL_DECLARED
-#define Tcl_SetObjLength_TCL_DECLARED
/* 64 */
EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
-#endif
-#ifndef Tcl_SetStringObj_TCL_DECLARED
-#define Tcl_SetStringObj_TCL_DECLARED
/* 65 */
-EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, CONST char *bytes,
+EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
int length);
-#endif
-#ifndef Tcl_AddErrorInfo_TCL_DECLARED
-#define Tcl_AddErrorInfo_TCL_DECLARED
/* 66 */
EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp,
- CONST char *message);
-#endif
-#ifndef Tcl_AddObjErrorInfo_TCL_DECLARED
-#define Tcl_AddObjErrorInfo_TCL_DECLARED
+ const char *message);
/* 67 */
EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
- CONST char *message, int length);
-#endif
-#ifndef Tcl_AllowExceptions_TCL_DECLARED
-#define Tcl_AllowExceptions_TCL_DECLARED
+ const char *message, int length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_AppendElement_TCL_DECLARED
-#define Tcl_AppendElement_TCL_DECLARED
/* 69 */
EXTERN void Tcl_AppendElement(Tcl_Interp *interp,
- CONST char *element);
-#endif
-#ifndef Tcl_AppendResult_TCL_DECLARED
-#define Tcl_AppendResult_TCL_DECLARED
+ const char *element);
/* 70 */
EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...);
-#endif
-#ifndef Tcl_AsyncCreate_TCL_DECLARED
-#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_AsyncDelete_TCL_DECLARED
-#define Tcl_AsyncDelete_TCL_DECLARED
/* 72 */
EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async);
-#endif
-#ifndef Tcl_AsyncInvoke_TCL_DECLARED
-#define Tcl_AsyncInvoke_TCL_DECLARED
/* 73 */
EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code);
-#endif
-#ifndef Tcl_AsyncMark_TCL_DECLARED
-#define Tcl_AsyncMark_TCL_DECLARED
/* 74 */
EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async);
-#endif
-#ifndef Tcl_AsyncReady_TCL_DECLARED
-#define Tcl_AsyncReady_TCL_DECLARED
/* 75 */
EXTERN int Tcl_AsyncReady(void);
-#endif
-#ifndef Tcl_BackgroundError_TCL_DECLARED
-#define Tcl_BackgroundError_TCL_DECLARED
/* 76 */
EXTERN void Tcl_BackgroundError(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_Backslash_TCL_DECLARED
-#define Tcl_Backslash_TCL_DECLARED
/* 77 */
-EXTERN char Tcl_Backslash(CONST char *src, int *readPtr);
-#endif
-#ifndef Tcl_BadChannelOption_TCL_DECLARED
-#define Tcl_BadChannelOption_TCL_DECLARED
+EXTERN char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
- CONST char *optionName,
- CONST char *optionList);
-#endif
-#ifndef Tcl_CallWhenDeleted_TCL_DECLARED
-#define Tcl_CallWhenDeleted_TCL_DECLARED
+ const char *optionName,
+ const char *optionList);
/* 79 */
EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_CancelIdleCall_TCL_DECLARED
-#define Tcl_CancelIdleCall_TCL_DECLARED
/* 80 */
EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc,
ClientData clientData);
-#endif
-#ifndef Tcl_Close_TCL_DECLARED
-#define Tcl_Close_TCL_DECLARED
/* 81 */
EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan);
-#endif
-#ifndef Tcl_CommandComplete_TCL_DECLARED
-#define Tcl_CommandComplete_TCL_DECLARED
/* 82 */
-EXTERN int Tcl_CommandComplete(CONST char *cmd);
-#endif
-#ifndef Tcl_Concat_TCL_DECLARED
-#define Tcl_Concat_TCL_DECLARED
+EXTERN int Tcl_CommandComplete(const char *cmd);
/* 83 */
-EXTERN char * Tcl_Concat(int argc, CONST84 char *CONST *argv);
-#endif
-#ifndef Tcl_ConvertElement_TCL_DECLARED
-#define Tcl_ConvertElement_TCL_DECLARED
+EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv);
/* 84 */
-EXTERN int Tcl_ConvertElement(CONST char *src, char *dst,
+EXTERN int Tcl_ConvertElement(const char *src, char *dst,
int flags);
-#endif
-#ifndef Tcl_ConvertCountedElement_TCL_DECLARED
-#define Tcl_ConvertCountedElement_TCL_DECLARED
/* 85 */
-EXTERN int Tcl_ConvertCountedElement(CONST char *src,
+EXTERN int Tcl_ConvertCountedElement(const char *src,
int length, char *dst, int flags);
-#endif
-#ifndef Tcl_CreateAlias_TCL_DECLARED
-#define Tcl_CreateAlias_TCL_DECLARED
/* 86 */
EXTERN int Tcl_CreateAlias(Tcl_Interp *slave,
- CONST char *slaveCmd, Tcl_Interp *target,
- CONST char *targetCmd, int argc,
- CONST84 char *CONST *argv);
-#endif
-#ifndef Tcl_CreateAliasObj_TCL_DECLARED
-#define Tcl_CreateAliasObj_TCL_DECLARED
+ const char *slaveCmd, Tcl_Interp *target,
+ const char *targetCmd, int argc,
+ CONST84 char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
- CONST char *slaveCmd, Tcl_Interp *target,
- CONST char *targetCmd, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_CreateChannel_TCL_DECLARED
-#define Tcl_CreateChannel_TCL_DECLARED
+ const char *slaveCmd, Tcl_Interp *target,
+ const char *targetCmd, int objc,
+ Tcl_Obj *const objv[]);
/* 88 */
-EXTERN Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr,
- CONST char *chanName,
+EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
+ const char *chanName,
ClientData instanceData, int mask);
-#endif
-#ifndef Tcl_CreateChannelHandler_TCL_DECLARED
-#define Tcl_CreateChannelHandler_TCL_DECLARED
/* 89 */
EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData);
-#endif
-#ifndef Tcl_CreateCloseHandler_TCL_DECLARED
-#define Tcl_CreateCloseHandler_TCL_DECLARED
/* 90 */
EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData);
-#endif
-#ifndef Tcl_CreateCommand_TCL_DECLARED
-#define Tcl_CreateCommand_TCL_DECLARED
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp,
- CONST char *cmdName, Tcl_CmdProc *proc,
+ const char *cmdName, Tcl_CmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
-#endif
-#ifndef Tcl_CreateEventSource_TCL_DECLARED
-#define Tcl_CreateEventSource_TCL_DECLARED
/* 92 */
EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData);
-#endif
-#ifndef Tcl_CreateExitHandler_TCL_DECLARED
-#define Tcl_CreateExitHandler_TCL_DECLARED
/* 93 */
EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_CreateInterp_TCL_DECLARED
-#define Tcl_CreateInterp_TCL_DECLARED
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
-#endif
-#ifndef Tcl_CreateMathFunc_TCL_DECLARED
-#define Tcl_CreateMathFunc_TCL_DECLARED
/* 95 */
EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp,
- CONST char *name, int numArgs,
+ const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_CreateObjCommand_TCL_DECLARED
-#define Tcl_CreateObjCommand_TCL_DECLARED
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
- CONST char *cmdName, Tcl_ObjCmdProc *proc,
+ const char *cmdName, Tcl_ObjCmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
-#endif
-#ifndef Tcl_CreateSlave_TCL_DECLARED
-#define Tcl_CreateSlave_TCL_DECLARED
/* 97 */
EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp,
- CONST char *slaveName, int isSafe);
-#endif
-#ifndef Tcl_CreateTimerHandler_TCL_DECLARED
-#define Tcl_CreateTimerHandler_TCL_DECLARED
+ const char *slaveName, int isSafe);
/* 98 */
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData);
-#endif
-#ifndef Tcl_CreateTrace_TCL_DECLARED
-#define Tcl_CreateTrace_TCL_DECLARED
/* 99 */
EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DeleteAssocData_TCL_DECLARED
-#define Tcl_DeleteAssocData_TCL_DECLARED
/* 100 */
EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp,
- CONST char *name);
-#endif
-#ifndef Tcl_DeleteChannelHandler_TCL_DECLARED
-#define Tcl_DeleteChannelHandler_TCL_DECLARED
+ const char *name);
/* 101 */
EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan,
Tcl_ChannelProc *proc, ClientData clientData);
-#endif
-#ifndef Tcl_DeleteCloseHandler_TCL_DECLARED
-#define Tcl_DeleteCloseHandler_TCL_DECLARED
/* 102 */
EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData);
-#endif
-#ifndef Tcl_DeleteCommand_TCL_DECLARED
-#define Tcl_DeleteCommand_TCL_DECLARED
/* 103 */
EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp,
- CONST char *cmdName);
-#endif
-#ifndef Tcl_DeleteCommandFromToken_TCL_DECLARED
-#define Tcl_DeleteCommandFromToken_TCL_DECLARED
+ const char *cmdName);
/* 104 */
EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp,
Tcl_Command command);
-#endif
-#ifndef Tcl_DeleteEvents_TCL_DECLARED
-#define Tcl_DeleteEvents_TCL_DECLARED
/* 105 */
EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DeleteEventSource_TCL_DECLARED
-#define Tcl_DeleteEventSource_TCL_DECLARED
/* 106 */
EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData);
-#endif
-#ifndef Tcl_DeleteExitHandler_TCL_DECLARED
-#define Tcl_DeleteExitHandler_TCL_DECLARED
/* 107 */
EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DeleteHashEntry_TCL_DECLARED
-#define Tcl_DeleteHashEntry_TCL_DECLARED
/* 108 */
EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr);
-#endif
-#ifndef Tcl_DeleteHashTable_TCL_DECLARED
-#define Tcl_DeleteHashTable_TCL_DECLARED
/* 109 */
EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr);
-#endif
-#ifndef Tcl_DeleteInterp_TCL_DECLARED
-#define Tcl_DeleteInterp_TCL_DECLARED
/* 110 */
EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_DetachPids_TCL_DECLARED
-#define Tcl_DetachPids_TCL_DECLARED
/* 111 */
EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr);
-#endif
-#ifndef Tcl_DeleteTimerHandler_TCL_DECLARED
-#define Tcl_DeleteTimerHandler_TCL_DECLARED
/* 112 */
EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token);
-#endif
-#ifndef Tcl_DeleteTrace_TCL_DECLARED
-#define Tcl_DeleteTrace_TCL_DECLARED
/* 113 */
EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace);
-#endif
-#ifndef Tcl_DontCallWhenDeleted_TCL_DECLARED
-#define Tcl_DontCallWhenDeleted_TCL_DECLARED
/* 114 */
EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DoOneEvent_TCL_DECLARED
-#define Tcl_DoOneEvent_TCL_DECLARED
/* 115 */
EXTERN int Tcl_DoOneEvent(int flags);
-#endif
-#ifndef Tcl_DoWhenIdle_TCL_DECLARED
-#define Tcl_DoWhenIdle_TCL_DECLARED
/* 116 */
EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DStringAppend_TCL_DECLARED
-#define Tcl_DStringAppend_TCL_DECLARED
/* 117 */
EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr,
- CONST char *bytes, int length);
-#endif
-#ifndef Tcl_DStringAppendElement_TCL_DECLARED
-#define Tcl_DStringAppendElement_TCL_DECLARED
+ const char *bytes, int length);
/* 118 */
EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr,
- CONST char *element);
-#endif
-#ifndef Tcl_DStringEndSublist_TCL_DECLARED
-#define Tcl_DStringEndSublist_TCL_DECLARED
+ const char *element);
/* 119 */
EXTERN void Tcl_DStringEndSublist(Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_DStringFree_TCL_DECLARED
-#define Tcl_DStringFree_TCL_DECLARED
/* 120 */
EXTERN void Tcl_DStringFree(Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_DStringGetResult_TCL_DECLARED
-#define Tcl_DStringGetResult_TCL_DECLARED
/* 121 */
EXTERN void Tcl_DStringGetResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_DStringInit_TCL_DECLARED
-#define Tcl_DStringInit_TCL_DECLARED
/* 122 */
EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_DStringResult_TCL_DECLARED
-#define Tcl_DStringResult_TCL_DECLARED
/* 123 */
EXTERN void Tcl_DStringResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_DStringSetLength_TCL_DECLARED
-#define Tcl_DStringSetLength_TCL_DECLARED
/* 124 */
EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length);
-#endif
-#ifndef Tcl_DStringStartSublist_TCL_DECLARED
-#define Tcl_DStringStartSublist_TCL_DECLARED
/* 125 */
EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_Eof_TCL_DECLARED
-#define Tcl_Eof_TCL_DECLARED
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
-#endif
-#ifndef Tcl_ErrnoId_TCL_DECLARED
-#define Tcl_ErrnoId_TCL_DECLARED
/* 127 */
EXTERN CONST84_RETURN char * Tcl_ErrnoId(void);
-#endif
-#ifndef Tcl_ErrnoMsg_TCL_DECLARED
-#define Tcl_ErrnoMsg_TCL_DECLARED
/* 128 */
EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err);
-#endif
-#ifndef Tcl_Eval_TCL_DECLARED
-#define Tcl_Eval_TCL_DECLARED
/* 129 */
-EXTERN int Tcl_Eval(Tcl_Interp *interp, CONST char *script);
-#endif
-#ifndef Tcl_EvalFile_TCL_DECLARED
-#define Tcl_EvalFile_TCL_DECLARED
+EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
EXTERN int Tcl_EvalFile(Tcl_Interp *interp,
- CONST char *fileName);
-#endif
-#ifndef Tcl_EvalObj_TCL_DECLARED
-#define Tcl_EvalObj_TCL_DECLARED
+ const char *fileName);
/* 131 */
EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_EventuallyFree_TCL_DECLARED
-#define Tcl_EventuallyFree_TCL_DECLARED
/* 132 */
EXTERN void Tcl_EventuallyFree(ClientData clientData,
Tcl_FreeProc *freeProc);
-#endif
-#ifndef Tcl_Exit_TCL_DECLARED
-#define Tcl_Exit_TCL_DECLARED
/* 133 */
EXTERN void Tcl_Exit(int status);
-#endif
-#ifndef Tcl_ExposeCommand_TCL_DECLARED
-#define Tcl_ExposeCommand_TCL_DECLARED
/* 134 */
EXTERN int Tcl_ExposeCommand(Tcl_Interp *interp,
- CONST char *hiddenCmdToken,
- CONST char *cmdName);
-#endif
-#ifndef Tcl_ExprBoolean_TCL_DECLARED
-#define Tcl_ExprBoolean_TCL_DECLARED
+ const char *hiddenCmdToken,
+ const char *cmdName);
/* 135 */
-EXTERN int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr,
+EXTERN int Tcl_ExprBoolean(Tcl_Interp *interp, const char *expr,
int *ptr);
-#endif
-#ifndef Tcl_ExprBooleanObj_TCL_DECLARED
-#define Tcl_ExprBooleanObj_TCL_DECLARED
/* 136 */
EXTERN int Tcl_ExprBooleanObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *ptr);
-#endif
-#ifndef Tcl_ExprDouble_TCL_DECLARED
-#define Tcl_ExprDouble_TCL_DECLARED
/* 137 */
-EXTERN int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr,
+EXTERN int Tcl_ExprDouble(Tcl_Interp *interp, const char *expr,
double *ptr);
-#endif
-#ifndef Tcl_ExprDoubleObj_TCL_DECLARED
-#define Tcl_ExprDoubleObj_TCL_DECLARED
/* 138 */
EXTERN int Tcl_ExprDoubleObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *ptr);
-#endif
-#ifndef Tcl_ExprLong_TCL_DECLARED
-#define Tcl_ExprLong_TCL_DECLARED
/* 139 */
-EXTERN int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr,
+EXTERN int Tcl_ExprLong(Tcl_Interp *interp, const char *expr,
long *ptr);
-#endif
-#ifndef Tcl_ExprLongObj_TCL_DECLARED
-#define Tcl_ExprLongObj_TCL_DECLARED
/* 140 */
EXTERN int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
long *ptr);
-#endif
-#ifndef Tcl_ExprObj_TCL_DECLARED
-#define Tcl_ExprObj_TCL_DECLARED
/* 141 */
EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Obj **resultPtrPtr);
-#endif
-#ifndef Tcl_ExprString_TCL_DECLARED
-#define Tcl_ExprString_TCL_DECLARED
/* 142 */
-EXTERN int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr);
-#endif
-#ifndef Tcl_Finalize_TCL_DECLARED
-#define Tcl_Finalize_TCL_DECLARED
+EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr);
/* 143 */
EXTERN void Tcl_Finalize(void);
-#endif
-#ifndef Tcl_FindExecutable_TCL_DECLARED
-#define Tcl_FindExecutable_TCL_DECLARED
/* 144 */
-EXTERN void Tcl_FindExecutable(CONST char *argv0);
-#endif
-#ifndef Tcl_FirstHashEntry_TCL_DECLARED
-#define Tcl_FirstHashEntry_TCL_DECLARED
+EXTERN void Tcl_FindExecutable(const char *argv0);
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr);
-#endif
-#ifndef Tcl_Flush_TCL_DECLARED
-#define Tcl_Flush_TCL_DECLARED
/* 146 */
EXTERN int Tcl_Flush(Tcl_Channel chan);
-#endif
-#ifndef Tcl_FreeResult_TCL_DECLARED
-#define Tcl_FreeResult_TCL_DECLARED
/* 147 */
EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetAlias_TCL_DECLARED
-#define Tcl_GetAlias_TCL_DECLARED
/* 148 */
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
- CONST char *slaveCmd,
+ const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
CONST84 char **targetCmdPtr, int *argcPtr,
CONST84 char ***argvPtr);
-#endif
-#ifndef Tcl_GetAliasObj_TCL_DECLARED
-#define Tcl_GetAliasObj_TCL_DECLARED
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
- CONST char *slaveCmd,
+ const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
CONST84 char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
-#endif
-#ifndef Tcl_GetAssocData_TCL_DECLARED
-#define Tcl_GetAssocData_TCL_DECLARED
/* 150 */
EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_InterpDeleteProc **procPtr);
-#endif
-#ifndef Tcl_GetChannel_TCL_DECLARED
-#define Tcl_GetChannel_TCL_DECLARED
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp,
- CONST char *chanName, int *modePtr);
-#endif
-#ifndef Tcl_GetChannelBufferSize_TCL_DECLARED
-#define Tcl_GetChannelBufferSize_TCL_DECLARED
+ const char *chanName, int *modePtr);
/* 152 */
EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetChannelHandle_TCL_DECLARED
-#define Tcl_GetChannelHandle_TCL_DECLARED
/* 153 */
EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr);
-#endif
-#ifndef Tcl_GetChannelInstanceData_TCL_DECLARED
-#define Tcl_GetChannelInstanceData_TCL_DECLARED
/* 154 */
EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetChannelMode_TCL_DECLARED
-#define Tcl_GetChannelMode_TCL_DECLARED
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetChannelName_TCL_DECLARED
-#define Tcl_GetChannelName_TCL_DECLARED
/* 156 */
EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetChannelOption_TCL_DECLARED
-#define Tcl_GetChannelOption_TCL_DECLARED
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
- Tcl_Channel chan, CONST char *optionName,
+ Tcl_Channel chan, const char *optionName,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_GetChannelType_TCL_DECLARED
-#define Tcl_GetChannelType_TCL_DECLARED
/* 158 */
-EXTERN Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetCommandInfo_TCL_DECLARED
-#define Tcl_GetCommandInfo_TCL_DECLARED
+EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
/* 159 */
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
- CONST char *cmdName, Tcl_CmdInfo *infoPtr);
-#endif
-#ifndef Tcl_GetCommandName_TCL_DECLARED
-#define Tcl_GetCommandName_TCL_DECLARED
+ const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
-#endif
-#ifndef Tcl_GetErrno_TCL_DECLARED
-#define Tcl_GetErrno_TCL_DECLARED
/* 161 */
EXTERN int Tcl_GetErrno(void);
-#endif
-#ifndef Tcl_GetHostName_TCL_DECLARED
-#define Tcl_GetHostName_TCL_DECLARED
/* 162 */
EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
-#endif
-#ifndef Tcl_GetInterpPath_TCL_DECLARED
-#define Tcl_GetInterpPath_TCL_DECLARED
/* 163 */
EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp,
Tcl_Interp *slaveInterp);
-#endif
-#ifndef Tcl_GetMaster_TCL_DECLARED
-#define Tcl_GetMaster_TCL_DECLARED
/* 164 */
EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetNameOfExecutable_TCL_DECLARED
-#define Tcl_GetNameOfExecutable_TCL_DECLARED
/* 165 */
-EXTERN CONST char * Tcl_GetNameOfExecutable(void);
-#endif
-#ifndef Tcl_GetObjResult_TCL_DECLARED
-#define Tcl_GetObjResult_TCL_DECLARED
+EXTERN const char * Tcl_GetNameOfExecutable(void);
/* 166 */
EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp);
-#endif
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_GetOpenFile_TCL_DECLARED
-#define Tcl_GetOpenFile_TCL_DECLARED
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
- CONST char *chanID, int forWriting,
+ const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr);
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_GetOpenFile_TCL_DECLARED
-#define Tcl_GetOpenFile_TCL_DECLARED
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
- CONST char *chanID, int forWriting,
+ const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr);
-#endif
#endif /* MACOSX */
-#ifndef Tcl_GetPathType_TCL_DECLARED
-#define Tcl_GetPathType_TCL_DECLARED
/* 168 */
-EXTERN Tcl_PathType Tcl_GetPathType(CONST char *path);
-#endif
-#ifndef Tcl_Gets_TCL_DECLARED
-#define Tcl_Gets_TCL_DECLARED
+EXTERN Tcl_PathType Tcl_GetPathType(const char *path);
/* 169 */
EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_GetsObj_TCL_DECLARED
-#define Tcl_GetsObj_TCL_DECLARED
/* 170 */
EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetServiceMode_TCL_DECLARED
-#define Tcl_GetServiceMode_TCL_DECLARED
/* 171 */
EXTERN int Tcl_GetServiceMode(void);
-#endif
-#ifndef Tcl_GetSlave_TCL_DECLARED
-#define Tcl_GetSlave_TCL_DECLARED
/* 172 */
EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp,
- CONST char *slaveName);
-#endif
-#ifndef Tcl_GetStdChannel_TCL_DECLARED
-#define Tcl_GetStdChannel_TCL_DECLARED
+ const char *slaveName);
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
-#endif
-#ifndef Tcl_GetStringResult_TCL_DECLARED
-#define Tcl_GetStringResult_TCL_DECLARED
/* 174 */
EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetVar_TCL_DECLARED
-#define Tcl_GetVar_TCL_DECLARED
/* 175 */
EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp,
- CONST char *varName, int flags);
-#endif
-#ifndef Tcl_GetVar2_TCL_DECLARED
-#define Tcl_GetVar2_TCL_DECLARED
+ const char *varName, int flags);
/* 176 */
EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp,
- CONST char *part1, CONST char *part2,
+ const char *part1, const char *part2,
int flags);
-#endif
-#ifndef Tcl_GlobalEval_TCL_DECLARED
-#define Tcl_GlobalEval_TCL_DECLARED
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
- CONST char *command);
-#endif
-#ifndef Tcl_GlobalEvalObj_TCL_DECLARED
-#define Tcl_GlobalEvalObj_TCL_DECLARED
+ const char *command);
/* 178 */
EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_HideCommand_TCL_DECLARED
-#define Tcl_HideCommand_TCL_DECLARED
/* 179 */
EXTERN int Tcl_HideCommand(Tcl_Interp *interp,
- CONST char *cmdName,
- CONST char *hiddenCmdToken);
-#endif
-#ifndef Tcl_Init_TCL_DECLARED
-#define Tcl_Init_TCL_DECLARED
+ const char *cmdName,
+ const char *hiddenCmdToken);
/* 180 */
EXTERN int Tcl_Init(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_InitHashTable_TCL_DECLARED
-#define Tcl_InitHashTable_TCL_DECLARED
/* 181 */
EXTERN void Tcl_InitHashTable(Tcl_HashTable *tablePtr,
int keyType);
-#endif
-#ifndef Tcl_InputBlocked_TCL_DECLARED
-#define Tcl_InputBlocked_TCL_DECLARED
/* 182 */
EXTERN int Tcl_InputBlocked(Tcl_Channel chan);
-#endif
-#ifndef Tcl_InputBuffered_TCL_DECLARED
-#define Tcl_InputBuffered_TCL_DECLARED
/* 183 */
EXTERN int Tcl_InputBuffered(Tcl_Channel chan);
-#endif
-#ifndef Tcl_InterpDeleted_TCL_DECLARED
-#define Tcl_InterpDeleted_TCL_DECLARED
/* 184 */
EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_IsSafe_TCL_DECLARED
-#define Tcl_IsSafe_TCL_DECLARED
/* 185 */
EXTERN int Tcl_IsSafe(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_JoinPath_TCL_DECLARED
-#define Tcl_JoinPath_TCL_DECLARED
/* 186 */
-EXTERN char * Tcl_JoinPath(int argc, CONST84 char *CONST *argv,
+EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv,
Tcl_DString *resultPtr);
-#endif
-#ifndef Tcl_LinkVar_TCL_DECLARED
-#define Tcl_LinkVar_TCL_DECLARED
/* 187 */
-EXTERN int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName,
+EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
char *addr, int type);
-#endif
/* Slot 188 is reserved */
-#ifndef Tcl_MakeFileChannel_TCL_DECLARED
-#define Tcl_MakeFileChannel_TCL_DECLARED
/* 189 */
EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode);
-#endif
-#ifndef Tcl_MakeSafe_TCL_DECLARED
-#define Tcl_MakeSafe_TCL_DECLARED
/* 190 */
EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_MakeTcpClientChannel_TCL_DECLARED
-#define Tcl_MakeTcpClientChannel_TCL_DECLARED
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
-#endif
-#ifndef Tcl_Merge_TCL_DECLARED
-#define Tcl_Merge_TCL_DECLARED
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *CONST *argv);
-#endif
-#ifndef Tcl_NextHashEntry_TCL_DECLARED
-#define Tcl_NextHashEntry_TCL_DECLARED
+EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
-#endif
-#ifndef Tcl_NotifyChannel_TCL_DECLARED
-#define Tcl_NotifyChannel_TCL_DECLARED
/* 194 */
EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask);
-#endif
-#ifndef Tcl_ObjGetVar2_TCL_DECLARED
-#define Tcl_ObjGetVar2_TCL_DECLARED
/* 195 */
EXTERN Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags);
-#endif
-#ifndef Tcl_ObjSetVar2_TCL_DECLARED
-#define Tcl_ObjSetVar2_TCL_DECLARED
/* 196 */
EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
int flags);
-#endif
-#ifndef Tcl_OpenCommandChannel_TCL_DECLARED
-#define Tcl_OpenCommandChannel_TCL_DECLARED
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
CONST84 char **argv, int flags);
-#endif
-#ifndef Tcl_OpenFileChannel_TCL_DECLARED
-#define Tcl_OpenFileChannel_TCL_DECLARED
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
- CONST char *fileName, CONST char *modeString,
+ const char *fileName, const char *modeString,
int permissions);
-#endif
-#ifndef Tcl_OpenTcpClient_TCL_DECLARED
-#define Tcl_OpenTcpClient_TCL_DECLARED
/* 199 */
EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
- CONST char *address, CONST char *myaddr,
+ const char *address, const char *myaddr,
int myport, int async);
-#endif
-#ifndef Tcl_OpenTcpServer_TCL_DECLARED
-#define Tcl_OpenTcpServer_TCL_DECLARED
/* 200 */
EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
- CONST char *host,
+ const char *host,
Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData);
-#endif
-#ifndef Tcl_Preserve_TCL_DECLARED
-#define Tcl_Preserve_TCL_DECLARED
/* 201 */
EXTERN void Tcl_Preserve(ClientData data);
-#endif
-#ifndef Tcl_PrintDouble_TCL_DECLARED
-#define Tcl_PrintDouble_TCL_DECLARED
/* 202 */
EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
char *dst);
-#endif
-#ifndef Tcl_PutEnv_TCL_DECLARED
-#define Tcl_PutEnv_TCL_DECLARED
/* 203 */
-EXTERN int Tcl_PutEnv(CONST char *assignment);
-#endif
-#ifndef Tcl_PosixError_TCL_DECLARED
-#define Tcl_PosixError_TCL_DECLARED
+EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_QueueEvent_TCL_DECLARED
-#define Tcl_QueueEvent_TCL_DECLARED
/* 205 */
EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr,
Tcl_QueuePosition position);
-#endif
-#ifndef Tcl_Read_TCL_DECLARED
-#define Tcl_Read_TCL_DECLARED
/* 206 */
EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead);
-#endif
-#ifndef Tcl_ReapDetachedProcs_TCL_DECLARED
-#define Tcl_ReapDetachedProcs_TCL_DECLARED
/* 207 */
EXTERN void Tcl_ReapDetachedProcs(void);
-#endif
-#ifndef Tcl_RecordAndEval_TCL_DECLARED
-#define Tcl_RecordAndEval_TCL_DECLARED
/* 208 */
EXTERN int Tcl_RecordAndEval(Tcl_Interp *interp,
- CONST char *cmd, int flags);
-#endif
-#ifndef Tcl_RecordAndEvalObj_TCL_DECLARED
-#define Tcl_RecordAndEvalObj_TCL_DECLARED
+ const char *cmd, int flags);
/* 209 */
EXTERN int Tcl_RecordAndEvalObj(Tcl_Interp *interp,
Tcl_Obj *cmdPtr, int flags);
-#endif
-#ifndef Tcl_RegisterChannel_TCL_DECLARED
-#define Tcl_RegisterChannel_TCL_DECLARED
/* 210 */
EXTERN void Tcl_RegisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef Tcl_RegisterObjType_TCL_DECLARED
-#define Tcl_RegisterObjType_TCL_DECLARED
/* 211 */
-EXTERN void Tcl_RegisterObjType(Tcl_ObjType *typePtr);
-#endif
-#ifndef Tcl_RegExpCompile_TCL_DECLARED
-#define Tcl_RegExpCompile_TCL_DECLARED
+EXTERN void Tcl_RegisterObjType(const Tcl_ObjType *typePtr);
/* 212 */
EXTERN Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp,
- CONST char *pattern);
-#endif
-#ifndef Tcl_RegExpExec_TCL_DECLARED
-#define Tcl_RegExpExec_TCL_DECLARED
+ const char *pattern);
/* 213 */
EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
- CONST char *text, CONST char *start);
-#endif
-#ifndef Tcl_RegExpMatch_TCL_DECLARED
-#define Tcl_RegExpMatch_TCL_DECLARED
+ const char *text, const char *start);
/* 214 */
-EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text,
- CONST char *pattern);
-#endif
-#ifndef Tcl_RegExpRange_TCL_DECLARED
-#define Tcl_RegExpRange_TCL_DECLARED
+EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
+ const char *pattern);
/* 215 */
EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
CONST84 char **startPtr,
CONST84 char **endPtr);
-#endif
-#ifndef Tcl_Release_TCL_DECLARED
-#define Tcl_Release_TCL_DECLARED
/* 216 */
EXTERN void Tcl_Release(ClientData clientData);
-#endif
-#ifndef Tcl_ResetResult_TCL_DECLARED
-#define Tcl_ResetResult_TCL_DECLARED
/* 217 */
EXTERN void Tcl_ResetResult(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_ScanElement_TCL_DECLARED
-#define Tcl_ScanElement_TCL_DECLARED
/* 218 */
-EXTERN int Tcl_ScanElement(CONST char *str, int *flagPtr);
-#endif
-#ifndef Tcl_ScanCountedElement_TCL_DECLARED
-#define Tcl_ScanCountedElement_TCL_DECLARED
+EXTERN int Tcl_ScanElement(const char *str, int *flagPtr);
/* 219 */
-EXTERN int Tcl_ScanCountedElement(CONST char *str, int length,
+EXTERN int Tcl_ScanCountedElement(const char *str, int length,
int *flagPtr);
-#endif
-#ifndef Tcl_SeekOld_TCL_DECLARED
-#define Tcl_SeekOld_TCL_DECLARED
/* 220 */
EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
-#endif
-#ifndef Tcl_ServiceAll_TCL_DECLARED
-#define Tcl_ServiceAll_TCL_DECLARED
/* 221 */
EXTERN int Tcl_ServiceAll(void);
-#endif
-#ifndef Tcl_ServiceEvent_TCL_DECLARED
-#define Tcl_ServiceEvent_TCL_DECLARED
/* 222 */
EXTERN int Tcl_ServiceEvent(int flags);
-#endif
-#ifndef Tcl_SetAssocData_TCL_DECLARED
-#define Tcl_SetAssocData_TCL_DECLARED
/* 223 */
EXTERN void Tcl_SetAssocData(Tcl_Interp *interp,
- CONST char *name, Tcl_InterpDeleteProc *proc,
+ const char *name, Tcl_InterpDeleteProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_SetChannelBufferSize_TCL_DECLARED
-#define Tcl_SetChannelBufferSize_TCL_DECLARED
/* 224 */
EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz);
-#endif
-#ifndef Tcl_SetChannelOption_TCL_DECLARED
-#define Tcl_SetChannelOption_TCL_DECLARED
/* 225 */
EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp,
- Tcl_Channel chan, CONST char *optionName,
- CONST char *newValue);
-#endif
-#ifndef Tcl_SetCommandInfo_TCL_DECLARED
-#define Tcl_SetCommandInfo_TCL_DECLARED
+ Tcl_Channel chan, const char *optionName,
+ const char *newValue);
/* 226 */
EXTERN int Tcl_SetCommandInfo(Tcl_Interp *interp,
- CONST char *cmdName,
- CONST Tcl_CmdInfo *infoPtr);
-#endif
-#ifndef Tcl_SetErrno_TCL_DECLARED
-#define Tcl_SetErrno_TCL_DECLARED
+ const char *cmdName,
+ const Tcl_CmdInfo *infoPtr);
/* 227 */
EXTERN void Tcl_SetErrno(int err);
-#endif
-#ifndef Tcl_SetErrorCode_TCL_DECLARED
-#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...);
-#endif
-#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
-#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
-EXTERN void Tcl_SetMaxBlockTime(Tcl_Time *timePtr);
-#endif
-#ifndef Tcl_SetPanicProc_TCL_DECLARED
-#define Tcl_SetPanicProc_TCL_DECLARED
+EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr);
/* 230 */
EXTERN void Tcl_SetPanicProc(Tcl_PanicProc *panicProc);
-#endif
-#ifndef Tcl_SetRecursionLimit_TCL_DECLARED
-#define Tcl_SetRecursionLimit_TCL_DECLARED
/* 231 */
EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
-#endif
-#ifndef Tcl_SetResult_TCL_DECLARED
-#define Tcl_SetResult_TCL_DECLARED
/* 232 */
EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc);
-#endif
-#ifndef Tcl_SetServiceMode_TCL_DECLARED
-#define Tcl_SetServiceMode_TCL_DECLARED
/* 233 */
EXTERN int Tcl_SetServiceMode(int mode);
-#endif
-#ifndef Tcl_SetObjErrorCode_TCL_DECLARED
-#define Tcl_SetObjErrorCode_TCL_DECLARED
/* 234 */
EXTERN void Tcl_SetObjErrorCode(Tcl_Interp *interp,
Tcl_Obj *errorObjPtr);
-#endif
-#ifndef Tcl_SetObjResult_TCL_DECLARED
-#define Tcl_SetObjResult_TCL_DECLARED
/* 235 */
EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
Tcl_Obj *resultObjPtr);
-#endif
-#ifndef Tcl_SetStdChannel_TCL_DECLARED
-#define Tcl_SetStdChannel_TCL_DECLARED
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
-#endif
-#ifndef Tcl_SetVar_TCL_DECLARED
-#define Tcl_SetVar_TCL_DECLARED
/* 237 */
EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp,
- CONST char *varName, CONST char *newValue,
+ const char *varName, const char *newValue,
int flags);
-#endif
-#ifndef Tcl_SetVar2_TCL_DECLARED
-#define Tcl_SetVar2_TCL_DECLARED
/* 238 */
EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp,
- CONST char *part1, CONST char *part2,
- CONST char *newValue, int flags);
-#endif
-#ifndef Tcl_SignalId_TCL_DECLARED
-#define Tcl_SignalId_TCL_DECLARED
+ const char *part1, const char *part2,
+ const char *newValue, int flags);
/* 239 */
EXTERN CONST84_RETURN char * Tcl_SignalId(int sig);
-#endif
-#ifndef Tcl_SignalMsg_TCL_DECLARED
-#define Tcl_SignalMsg_TCL_DECLARED
/* 240 */
EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig);
-#endif
-#ifndef Tcl_SourceRCFile_TCL_DECLARED
-#define Tcl_SourceRCFile_TCL_DECLARED
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_SplitList_TCL_DECLARED
-#define Tcl_SplitList_TCL_DECLARED
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
- CONST char *listStr, int *argcPtr,
+ const char *listStr, int *argcPtr,
CONST84 char ***argvPtr);
-#endif
-#ifndef Tcl_SplitPath_TCL_DECLARED
-#define Tcl_SplitPath_TCL_DECLARED
/* 243 */
-EXTERN void Tcl_SplitPath(CONST char *path, int *argcPtr,
+EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
CONST84 char ***argvPtr);
-#endif
-#ifndef Tcl_StaticPackage_TCL_DECLARED
-#define Tcl_StaticPackage_TCL_DECLARED
/* 244 */
EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
- CONST char *pkgName,
+ const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
-#endif
-#ifndef Tcl_StringMatch_TCL_DECLARED
-#define Tcl_StringMatch_TCL_DECLARED
/* 245 */
-EXTERN int Tcl_StringMatch(CONST char *str, CONST char *pattern);
-#endif
-#ifndef Tcl_TellOld_TCL_DECLARED
-#define Tcl_TellOld_TCL_DECLARED
+EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
EXTERN int Tcl_TellOld(Tcl_Channel chan);
-#endif
-#ifndef Tcl_TraceVar_TCL_DECLARED
-#define Tcl_TraceVar_TCL_DECLARED
/* 247 */
-EXTERN int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName,
+EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_TraceVar2_TCL_DECLARED
-#define Tcl_TraceVar2_TCL_DECLARED
/* 248 */
-EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags,
+EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_TranslateFileName_TCL_DECLARED
-#define Tcl_TranslateFileName_TCL_DECLARED
/* 249 */
EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp,
- CONST char *name, Tcl_DString *bufferPtr);
-#endif
-#ifndef Tcl_Ungets_TCL_DECLARED
-#define Tcl_Ungets_TCL_DECLARED
+ const char *name, Tcl_DString *bufferPtr);
/* 250 */
-EXTERN int Tcl_Ungets(Tcl_Channel chan, CONST char *str,
+EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str,
int len, int atHead);
-#endif
-#ifndef Tcl_UnlinkVar_TCL_DECLARED
-#define Tcl_UnlinkVar_TCL_DECLARED
/* 251 */
EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
- CONST char *varName);
-#endif
-#ifndef Tcl_UnregisterChannel_TCL_DECLARED
-#define Tcl_UnregisterChannel_TCL_DECLARED
+ const char *varName);
/* 252 */
EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef Tcl_UnsetVar_TCL_DECLARED
-#define Tcl_UnsetVar_TCL_DECLARED
/* 253 */
-EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName,
+EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
int flags);
-#endif
-#ifndef Tcl_UnsetVar2_TCL_DECLARED
-#define Tcl_UnsetVar2_TCL_DECLARED
/* 254 */
-EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags);
-#endif
-#ifndef Tcl_UntraceVar_TCL_DECLARED
-#define Tcl_UntraceVar_TCL_DECLARED
+EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 255 */
EXTERN void Tcl_UntraceVar(Tcl_Interp *interp,
- CONST char *varName, int flags,
+ const char *varName, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_UntraceVar2_TCL_DECLARED
-#define Tcl_UntraceVar2_TCL_DECLARED
/* 256 */
EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
- CONST char *part1, CONST char *part2,
+ const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_UpdateLinkedVar_TCL_DECLARED
-#define Tcl_UpdateLinkedVar_TCL_DECLARED
/* 257 */
EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp,
- CONST char *varName);
-#endif
-#ifndef Tcl_UpVar_TCL_DECLARED
-#define Tcl_UpVar_TCL_DECLARED
+ const char *varName);
/* 258 */
-EXTERN int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName,
- CONST char *varName, CONST char *localName,
+EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+ const char *varName, const char *localName,
int flags);
-#endif
-#ifndef Tcl_UpVar2_TCL_DECLARED
-#define Tcl_UpVar2_TCL_DECLARED
/* 259 */
-EXTERN int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName,
- CONST char *part1, CONST char *part2,
- CONST char *localName, int flags);
-#endif
-#ifndef Tcl_VarEval_TCL_DECLARED
-#define Tcl_VarEval_TCL_DECLARED
+EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
+ const char *part1, const char *part2,
+ const char *localName, int flags);
/* 260 */
EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...);
-#endif
-#ifndef Tcl_VarTraceInfo_TCL_DECLARED
-#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
- CONST char *varName, int flags,
+ const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
-#endif
-#ifndef Tcl_VarTraceInfo2_TCL_DECLARED
-#define Tcl_VarTraceInfo2_TCL_DECLARED
/* 262 */
EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp,
- CONST char *part1, CONST char *part2,
+ const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
-#endif
-#ifndef Tcl_Write_TCL_DECLARED
-#define Tcl_Write_TCL_DECLARED
/* 263 */
-EXTERN int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen);
-#endif
-#ifndef Tcl_WrongNumArgs_TCL_DECLARED
-#define Tcl_WrongNumArgs_TCL_DECLARED
+EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen);
/* 264 */
EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], CONST char *message);
-#endif
-#ifndef Tcl_DumpActiveMemory_TCL_DECLARED
-#define Tcl_DumpActiveMemory_TCL_DECLARED
+ Tcl_Obj *const objv[], const char *message);
/* 265 */
-EXTERN int Tcl_DumpActiveMemory(CONST char *fileName);
-#endif
-#ifndef Tcl_ValidateAllMemory_TCL_DECLARED
-#define Tcl_ValidateAllMemory_TCL_DECLARED
+EXTERN int Tcl_DumpActiveMemory(const char *fileName);
/* 266 */
-EXTERN void Tcl_ValidateAllMemory(CONST char *file, int line);
-#endif
-#ifndef Tcl_AppendResultVA_TCL_DECLARED
-#define Tcl_AppendResultVA_TCL_DECLARED
+EXTERN void Tcl_ValidateAllMemory(const char *file, int line);
/* 267 */
EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
-#endif
-#ifndef Tcl_AppendStringsToObjVA_TCL_DECLARED
-#define Tcl_AppendStringsToObjVA_TCL_DECLARED
/* 268 */
EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
-#endif
-#ifndef Tcl_HashStats_TCL_DECLARED
-#define Tcl_HashStats_TCL_DECLARED
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
-#endif
-#ifndef Tcl_ParseVar_TCL_DECLARED
-#define Tcl_ParseVar_TCL_DECLARED
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
- CONST char *start, CONST84 char **termPtr);
-#endif
-#ifndef Tcl_PkgPresent_TCL_DECLARED
-#define Tcl_PkgPresent_TCL_DECLARED
+ const char *start, CONST84 char **termPtr);
/* 271 */
EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp,
- CONST char *name, CONST char *version,
+ const char *name, const char *version,
int exact);
-#endif
-#ifndef Tcl_PkgPresentEx_TCL_DECLARED
-#define Tcl_PkgPresentEx_TCL_DECLARED
/* 272 */
EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp,
- CONST char *name, CONST char *version,
- int exact, ClientData *clientDataPtr);
-#endif
-#ifndef Tcl_PkgProvide_TCL_DECLARED
-#define Tcl_PkgProvide_TCL_DECLARED
+ const char *name, const char *version,
+ int exact, void *clientDataPtr);
/* 273 */
-EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
- CONST char *version);
-#endif
-#ifndef Tcl_PkgRequire_TCL_DECLARED
-#define Tcl_PkgRequire_TCL_DECLARED
+EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+ const char *version);
/* 274 */
EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
- CONST char *name, CONST char *version,
+ const char *name, const char *version,
int exact);
-#endif
-#ifndef Tcl_SetErrorCodeVA_TCL_DECLARED
-#define Tcl_SetErrorCodeVA_TCL_DECLARED
/* 275 */
EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
-#endif
-#ifndef Tcl_VarEvalVA_TCL_DECLARED
-#define Tcl_VarEvalVA_TCL_DECLARED
/* 276 */
EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
-#endif
-#ifndef Tcl_WaitPid_TCL_DECLARED
-#define Tcl_WaitPid_TCL_DECLARED
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
-#endif
-#ifndef Tcl_PanicVA_TCL_DECLARED
-#define Tcl_PanicVA_TCL_DECLARED
/* 278 */
-EXTERN void Tcl_PanicVA(CONST char *format, va_list argList);
-#endif
-#ifndef Tcl_GetVersion_TCL_DECLARED
-#define Tcl_GetVersion_TCL_DECLARED
+EXTERN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
-#endif
-#ifndef Tcl_InitMemory_TCL_DECLARED
-#define Tcl_InitMemory_TCL_DECLARED
/* 280 */
EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_StackChannel_TCL_DECLARED
-#define Tcl_StackChannel_TCL_DECLARED
/* 281 */
EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
- Tcl_ChannelType *typePtr,
+ const Tcl_ChannelType *typePtr,
ClientData instanceData, int mask,
Tcl_Channel prevChan);
-#endif
-#ifndef Tcl_UnstackChannel_TCL_DECLARED
-#define Tcl_UnstackChannel_TCL_DECLARED
/* 282 */
EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef Tcl_GetStackedChannel_TCL_DECLARED
-#define Tcl_GetStackedChannel_TCL_DECLARED
/* 283 */
EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan);
-#endif
-#ifndef Tcl_SetMainLoop_TCL_DECLARED
-#define Tcl_SetMainLoop_TCL_DECLARED
/* 284 */
EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc);
-#endif
/* Slot 285 is reserved */
-#ifndef Tcl_AppendObjToObj_TCL_DECLARED
-#define Tcl_AppendObjToObj_TCL_DECLARED
/* 286 */
EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr,
Tcl_Obj *appendObjPtr);
-#endif
-#ifndef Tcl_CreateEncoding_TCL_DECLARED
-#define Tcl_CreateEncoding_TCL_DECLARED
/* 287 */
-EXTERN Tcl_Encoding Tcl_CreateEncoding(CONST Tcl_EncodingType *typePtr);
-#endif
-#ifndef Tcl_CreateThreadExitHandler_TCL_DECLARED
-#define Tcl_CreateThreadExitHandler_TCL_DECLARED
+EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr);
/* 288 */
EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DeleteThreadExitHandler_TCL_DECLARED
-#define Tcl_DeleteThreadExitHandler_TCL_DECLARED
/* 289 */
EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_DiscardResult_TCL_DECLARED
-#define Tcl_DiscardResult_TCL_DECLARED
/* 290 */
EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
-#endif
-#ifndef Tcl_EvalEx_TCL_DECLARED
-#define Tcl_EvalEx_TCL_DECLARED
/* 291 */
-EXTERN int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script,
+EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags);
-#endif
-#ifndef Tcl_EvalObjv_TCL_DECLARED
-#define Tcl_EvalObjv_TCL_DECLARED
/* 292 */
EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], int flags);
-#endif
-#ifndef Tcl_EvalObjEx_TCL_DECLARED
-#define Tcl_EvalObjEx_TCL_DECLARED
+ Tcl_Obj *const objv[], int flags);
/* 293 */
EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
-#endif
-#ifndef Tcl_ExitThread_TCL_DECLARED
-#define Tcl_ExitThread_TCL_DECLARED
/* 294 */
EXTERN void Tcl_ExitThread(int status);
-#endif
-#ifndef Tcl_ExternalToUtf_TCL_DECLARED
-#define Tcl_ExternalToUtf_TCL_DECLARED
/* 295 */
EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp,
- Tcl_Encoding encoding, CONST char *src,
+ Tcl_Encoding encoding, const char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
-#endif
-#ifndef Tcl_ExternalToUtfDString_TCL_DECLARED
-#define Tcl_ExternalToUtfDString_TCL_DECLARED
/* 296 */
EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- CONST char *src, int srcLen,
+ const char *src, int srcLen,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_FinalizeThread_TCL_DECLARED
-#define Tcl_FinalizeThread_TCL_DECLARED
/* 297 */
EXTERN void Tcl_FinalizeThread(void);
-#endif
-#ifndef Tcl_FinalizeNotifier_TCL_DECLARED
-#define Tcl_FinalizeNotifier_TCL_DECLARED
/* 298 */
EXTERN void Tcl_FinalizeNotifier(ClientData clientData);
-#endif
-#ifndef Tcl_FreeEncoding_TCL_DECLARED
-#define Tcl_FreeEncoding_TCL_DECLARED
/* 299 */
EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding);
-#endif
-#ifndef Tcl_GetCurrentThread_TCL_DECLARED
-#define Tcl_GetCurrentThread_TCL_DECLARED
/* 300 */
EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
-#endif
-#ifndef Tcl_GetEncoding_TCL_DECLARED
-#define Tcl_GetEncoding_TCL_DECLARED
/* 301 */
-EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name);
-#endif
-#ifndef Tcl_GetEncodingName_TCL_DECLARED
-#define Tcl_GetEncodingName_TCL_DECLARED
+EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding);
-#endif
-#ifndef Tcl_GetEncodingNames_TCL_DECLARED
-#define Tcl_GetEncodingNames_TCL_DECLARED
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetIndexFromObjStruct_TCL_DECLARED
-#define Tcl_GetIndexFromObjStruct_TCL_DECLARED
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp,
- Tcl_Obj *objPtr, CONST VOID *tablePtr,
- int offset, CONST char *msg, int flags,
+ Tcl_Obj *objPtr, const void *tablePtr,
+ int offset, const char *msg, int flags,
int *indexPtr);
-#endif
-#ifndef Tcl_GetThreadData_TCL_DECLARED
-#define Tcl_GetThreadData_TCL_DECLARED
/* 305 */
-EXTERN VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
+EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
int size);
-#endif
-#ifndef Tcl_GetVar2Ex_TCL_DECLARED
-#define Tcl_GetVar2Ex_TCL_DECLARED
/* 306 */
-EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags);
-#endif
-#ifndef Tcl_InitNotifier_TCL_DECLARED
-#define Tcl_InitNotifier_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 307 */
EXTERN ClientData Tcl_InitNotifier(void);
-#endif
-#ifndef Tcl_MutexLock_TCL_DECLARED
-#define Tcl_MutexLock_TCL_DECLARED
/* 308 */
EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr);
-#endif
-#ifndef Tcl_MutexUnlock_TCL_DECLARED
-#define Tcl_MutexUnlock_TCL_DECLARED
/* 309 */
EXTERN void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr);
-#endif
-#ifndef Tcl_ConditionNotify_TCL_DECLARED
-#define Tcl_ConditionNotify_TCL_DECLARED
/* 310 */
EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr);
-#endif
-#ifndef Tcl_ConditionWait_TCL_DECLARED
-#define Tcl_ConditionWait_TCL_DECLARED
/* 311 */
EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr,
- Tcl_Mutex *mutexPtr, Tcl_Time *timePtr);
-#endif
-#ifndef Tcl_NumUtfChars_TCL_DECLARED
-#define Tcl_NumUtfChars_TCL_DECLARED
+ Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr);
/* 312 */
-EXTERN int Tcl_NumUtfChars(CONST char *src, int length);
-#endif
-#ifndef Tcl_ReadChars_TCL_DECLARED
-#define Tcl_ReadChars_TCL_DECLARED
+EXTERN int Tcl_NumUtfChars(const char *src, int length);
/* 313 */
EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
int charsToRead, int appendFlag);
-#endif
-#ifndef Tcl_RestoreResult_TCL_DECLARED
-#define Tcl_RestoreResult_TCL_DECLARED
/* 314 */
EXTERN void Tcl_RestoreResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
-#endif
-#ifndef Tcl_SaveResult_TCL_DECLARED
-#define Tcl_SaveResult_TCL_DECLARED
/* 315 */
EXTERN void Tcl_SaveResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
-#endif
-#ifndef Tcl_SetSystemEncoding_TCL_DECLARED
-#define Tcl_SetSystemEncoding_TCL_DECLARED
/* 316 */
EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp,
- CONST char *name);
-#endif
-#ifndef Tcl_SetVar2Ex_TCL_DECLARED
-#define Tcl_SetVar2Ex_TCL_DECLARED
+ const char *name);
/* 317 */
-EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, Tcl_Obj *newValuePtr,
+EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
+ const char *part2, Tcl_Obj *newValuePtr,
int flags);
-#endif
-#ifndef Tcl_ThreadAlert_TCL_DECLARED
-#define Tcl_ThreadAlert_TCL_DECLARED
/* 318 */
EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
-#endif
-#ifndef Tcl_ThreadQueueEvent_TCL_DECLARED
-#define Tcl_ThreadQueueEvent_TCL_DECLARED
/* 319 */
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
Tcl_Event *evPtr, Tcl_QueuePosition position);
-#endif
-#ifndef Tcl_UniCharAtIndex_TCL_DECLARED
-#define Tcl_UniCharAtIndex_TCL_DECLARED
/* 320 */
-EXTERN Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index);
-#endif
-#ifndef Tcl_UniCharToLower_TCL_DECLARED
-#define Tcl_UniCharToLower_TCL_DECLARED
+EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index);
/* 321 */
EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch);
-#endif
-#ifndef Tcl_UniCharToTitle_TCL_DECLARED
-#define Tcl_UniCharToTitle_TCL_DECLARED
/* 322 */
EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch);
-#endif
-#ifndef Tcl_UniCharToUpper_TCL_DECLARED
-#define Tcl_UniCharToUpper_TCL_DECLARED
/* 323 */
EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
-#endif
-#ifndef Tcl_UniCharToUtf_TCL_DECLARED
-#define Tcl_UniCharToUtf_TCL_DECLARED
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
-#endif
-#ifndef Tcl_UtfAtIndex_TCL_DECLARED
-#define Tcl_UtfAtIndex_TCL_DECLARED
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index);
-#endif
-#ifndef Tcl_UtfCharComplete_TCL_DECLARED
-#define Tcl_UtfCharComplete_TCL_DECLARED
+EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
-EXTERN int Tcl_UtfCharComplete(CONST char *src, int length);
-#endif
-#ifndef Tcl_UtfBackslash_TCL_DECLARED
-#define Tcl_UtfBackslash_TCL_DECLARED
+EXTERN int Tcl_UtfCharComplete(const char *src, int length);
/* 327 */
-EXTERN int Tcl_UtfBackslash(CONST char *src, int *readPtr,
+EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
-#endif
-#ifndef Tcl_UtfFindFirst_TCL_DECLARED
-#define Tcl_UtfFindFirst_TCL_DECLARED
/* 328 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch);
-#endif
-#ifndef Tcl_UtfFindLast_TCL_DECLARED
-#define Tcl_UtfFindLast_TCL_DECLARED
+EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch);
-#endif
-#ifndef Tcl_UtfNext_TCL_DECLARED
-#define Tcl_UtfNext_TCL_DECLARED
+EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
-EXTERN CONST84_RETURN char * Tcl_UtfNext(CONST char *src);
-#endif
-#ifndef Tcl_UtfPrev_TCL_DECLARED
-#define Tcl_UtfPrev_TCL_DECLARED
+EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start);
-#endif
-#ifndef Tcl_UtfToExternal_TCL_DECLARED
-#define Tcl_UtfToExternal_TCL_DECLARED
+EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
- Tcl_Encoding encoding, CONST char *src,
+ Tcl_Encoding encoding, const char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
-#endif
-#ifndef Tcl_UtfToExternalDString_TCL_DECLARED
-#define Tcl_UtfToExternalDString_TCL_DECLARED
/* 333 */
EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- CONST char *src, int srcLen,
+ const char *src, int srcLen,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_UtfToLower_TCL_DECLARED
-#define Tcl_UtfToLower_TCL_DECLARED
/* 334 */
EXTERN int Tcl_UtfToLower(char *src);
-#endif
-#ifndef Tcl_UtfToTitle_TCL_DECLARED
-#define Tcl_UtfToTitle_TCL_DECLARED
/* 335 */
EXTERN int Tcl_UtfToTitle(char *src);
-#endif
-#ifndef Tcl_UtfToUniChar_TCL_DECLARED
-#define Tcl_UtfToUniChar_TCL_DECLARED
/* 336 */
-EXTERN int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr);
-#endif
-#ifndef Tcl_UtfToUpper_TCL_DECLARED
-#define Tcl_UtfToUpper_TCL_DECLARED
+EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr);
/* 337 */
EXTERN int Tcl_UtfToUpper(char *src);
-#endif
-#ifndef Tcl_WriteChars_TCL_DECLARED
-#define Tcl_WriteChars_TCL_DECLARED
/* 338 */
-EXTERN int Tcl_WriteChars(Tcl_Channel chan, CONST char *src,
+EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src,
int srcLen);
-#endif
-#ifndef Tcl_WriteObj_TCL_DECLARED
-#define Tcl_WriteObj_TCL_DECLARED
/* 339 */
EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetString_TCL_DECLARED
-#define Tcl_GetString_TCL_DECLARED
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetDefaultEncodingDir_TCL_DECLARED
-#define Tcl_GetDefaultEncodingDir_TCL_DECLARED
/* 341 */
EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void);
-#endif
-#ifndef Tcl_SetDefaultEncodingDir_TCL_DECLARED
-#define Tcl_SetDefaultEncodingDir_TCL_DECLARED
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir(CONST char *path);
-#endif
-#ifndef Tcl_AlertNotifier_TCL_DECLARED
-#define Tcl_AlertNotifier_TCL_DECLARED
+EXTERN void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
EXTERN void Tcl_AlertNotifier(ClientData clientData);
-#endif
-#ifndef Tcl_ServiceModeHook_TCL_DECLARED
-#define Tcl_ServiceModeHook_TCL_DECLARED
/* 344 */
EXTERN void Tcl_ServiceModeHook(int mode);
-#endif
-#ifndef Tcl_UniCharIsAlnum_TCL_DECLARED
-#define Tcl_UniCharIsAlnum_TCL_DECLARED
/* 345 */
EXTERN int Tcl_UniCharIsAlnum(int ch);
-#endif
-#ifndef Tcl_UniCharIsAlpha_TCL_DECLARED
-#define Tcl_UniCharIsAlpha_TCL_DECLARED
/* 346 */
EXTERN int Tcl_UniCharIsAlpha(int ch);
-#endif
-#ifndef Tcl_UniCharIsDigit_TCL_DECLARED
-#define Tcl_UniCharIsDigit_TCL_DECLARED
/* 347 */
EXTERN int Tcl_UniCharIsDigit(int ch);
-#endif
-#ifndef Tcl_UniCharIsLower_TCL_DECLARED
-#define Tcl_UniCharIsLower_TCL_DECLARED
/* 348 */
EXTERN int Tcl_UniCharIsLower(int ch);
-#endif
-#ifndef Tcl_UniCharIsSpace_TCL_DECLARED
-#define Tcl_UniCharIsSpace_TCL_DECLARED
/* 349 */
EXTERN int Tcl_UniCharIsSpace(int ch);
-#endif
-#ifndef Tcl_UniCharIsUpper_TCL_DECLARED
-#define Tcl_UniCharIsUpper_TCL_DECLARED
/* 350 */
EXTERN int Tcl_UniCharIsUpper(int ch);
-#endif
-#ifndef Tcl_UniCharIsWordChar_TCL_DECLARED
-#define Tcl_UniCharIsWordChar_TCL_DECLARED
/* 351 */
EXTERN int Tcl_UniCharIsWordChar(int ch);
-#endif
-#ifndef Tcl_UniCharLen_TCL_DECLARED
-#define Tcl_UniCharLen_TCL_DECLARED
/* 352 */
-EXTERN int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr);
-#endif
-#ifndef Tcl_UniCharNcmp_TCL_DECLARED
-#define Tcl_UniCharNcmp_TCL_DECLARED
+EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
/* 353 */
-EXTERN int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs,
- CONST Tcl_UniChar *uct,
+EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
+ const Tcl_UniChar *uct,
unsigned long numChars);
-#endif
-#ifndef Tcl_UniCharToUtfDString_TCL_DECLARED
-#define Tcl_UniCharToUtfDString_TCL_DECLARED
/* 354 */
-EXTERN char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr,
+EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
int uniLength, Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_UtfToUniCharDString_TCL_DECLARED
-#define Tcl_UtfToUniCharDString_TCL_DECLARED
/* 355 */
-EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *src, int length,
+EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_GetRegExpFromObj_TCL_DECLARED
-#define Tcl_GetRegExpFromObj_TCL_DECLARED
/* 356 */
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
-#endif
-#ifndef Tcl_EvalTokens_TCL_DECLARED
-#define Tcl_EvalTokens_TCL_DECLARED
/* 357 */
EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
-#endif
-#ifndef Tcl_FreeParse_TCL_DECLARED
-#define Tcl_FreeParse_TCL_DECLARED
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
-#endif
-#ifndef Tcl_LogCommandInfo_TCL_DECLARED
-#define Tcl_LogCommandInfo_TCL_DECLARED
/* 359 */
EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
- CONST char *script, CONST char *command,
+ const char *script, const char *command,
int length);
-#endif
-#ifndef Tcl_ParseBraces_TCL_DECLARED
-#define Tcl_ParseBraces_TCL_DECLARED
/* 360 */
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
- CONST char *start, int numBytes,
+ const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr);
-#endif
-#ifndef Tcl_ParseCommand_TCL_DECLARED
-#define Tcl_ParseCommand_TCL_DECLARED
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
- CONST char *start, int numBytes, int nested,
+ const char *start, int numBytes, int nested,
Tcl_Parse *parsePtr);
-#endif
-#ifndef Tcl_ParseExpr_TCL_DECLARED
-#define Tcl_ParseExpr_TCL_DECLARED
/* 362 */
-EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start,
+EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr);
-#endif
-#ifndef Tcl_ParseQuotedString_TCL_DECLARED
-#define Tcl_ParseQuotedString_TCL_DECLARED
/* 363 */
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
- CONST char *start, int numBytes,
+ const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr);
-#endif
-#ifndef Tcl_ParseVarName_TCL_DECLARED
-#define Tcl_ParseVarName_TCL_DECLARED
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
- CONST char *start, int numBytes,
+ const char *start, int numBytes,
Tcl_Parse *parsePtr, int append);
-#endif
-#ifndef Tcl_GetCwd_TCL_DECLARED
-#define Tcl_GetCwd_TCL_DECLARED
/* 365 */
EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
-#endif
-#ifndef Tcl_Chdir_TCL_DECLARED
-#define Tcl_Chdir_TCL_DECLARED
/* 366 */
-EXTERN int Tcl_Chdir(CONST char *dirName);
-#endif
-#ifndef Tcl_Access_TCL_DECLARED
-#define Tcl_Access_TCL_DECLARED
+EXTERN int Tcl_Chdir(const char *dirName);
/* 367 */
-EXTERN int Tcl_Access(CONST char *path, int mode);
-#endif
-#ifndef Tcl_Stat_TCL_DECLARED
-#define Tcl_Stat_TCL_DECLARED
+EXTERN int Tcl_Access(const char *path, int mode);
/* 368 */
-EXTERN int Tcl_Stat(CONST char *path, struct stat *bufPtr);
-#endif
-#ifndef Tcl_UtfNcmp_TCL_DECLARED
-#define Tcl_UtfNcmp_TCL_DECLARED
+EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr);
/* 369 */
-EXTERN int Tcl_UtfNcmp(CONST char *s1, CONST char *s2,
+EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2,
unsigned long n);
-#endif
-#ifndef Tcl_UtfNcasecmp_TCL_DECLARED
-#define Tcl_UtfNcasecmp_TCL_DECLARED
/* 370 */
-EXTERN int Tcl_UtfNcasecmp(CONST char *s1, CONST char *s2,
+EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2,
unsigned long n);
-#endif
-#ifndef Tcl_StringCaseMatch_TCL_DECLARED
-#define Tcl_StringCaseMatch_TCL_DECLARED
/* 371 */
-EXTERN int Tcl_StringCaseMatch(CONST char *str,
- CONST char *pattern, int nocase);
-#endif
-#ifndef Tcl_UniCharIsControl_TCL_DECLARED
-#define Tcl_UniCharIsControl_TCL_DECLARED
+EXTERN int Tcl_StringCaseMatch(const char *str,
+ const char *pattern, int nocase);
/* 372 */
EXTERN int Tcl_UniCharIsControl(int ch);
-#endif
-#ifndef Tcl_UniCharIsGraph_TCL_DECLARED
-#define Tcl_UniCharIsGraph_TCL_DECLARED
/* 373 */
EXTERN int Tcl_UniCharIsGraph(int ch);
-#endif
-#ifndef Tcl_UniCharIsPrint_TCL_DECLARED
-#define Tcl_UniCharIsPrint_TCL_DECLARED
/* 374 */
EXTERN int Tcl_UniCharIsPrint(int ch);
-#endif
-#ifndef Tcl_UniCharIsPunct_TCL_DECLARED
-#define Tcl_UniCharIsPunct_TCL_DECLARED
/* 375 */
EXTERN int Tcl_UniCharIsPunct(int ch);
-#endif
-#ifndef Tcl_RegExpExecObj_TCL_DECLARED
-#define Tcl_RegExpExecObj_TCL_DECLARED
/* 376 */
EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp,
Tcl_RegExp regexp, Tcl_Obj *textObj,
int offset, int nmatches, int flags);
-#endif
-#ifndef Tcl_RegExpGetInfo_TCL_DECLARED
-#define Tcl_RegExpGetInfo_TCL_DECLARED
/* 377 */
EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp,
Tcl_RegExpInfo *infoPtr);
-#endif
-#ifndef Tcl_NewUnicodeObj_TCL_DECLARED
-#define Tcl_NewUnicodeObj_TCL_DECLARED
/* 378 */
-EXTERN Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode,
+EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode,
int numChars);
-#endif
-#ifndef Tcl_SetUnicodeObj_TCL_DECLARED
-#define Tcl_SetUnicodeObj_TCL_DECLARED
/* 379 */
EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
- CONST Tcl_UniChar *unicode, int numChars);
-#endif
-#ifndef Tcl_GetCharLength_TCL_DECLARED
-#define Tcl_GetCharLength_TCL_DECLARED
+ const Tcl_UniChar *unicode, int numChars);
/* 380 */
EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetUniChar_TCL_DECLARED
-#define Tcl_GetUniChar_TCL_DECLARED
/* 381 */
EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
-#endif
-#ifndef Tcl_GetUnicode_TCL_DECLARED
-#define Tcl_GetUnicode_TCL_DECLARED
/* 382 */
EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetRange_TCL_DECLARED
-#define Tcl_GetRange_TCL_DECLARED
/* 383 */
EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
-#endif
-#ifndef Tcl_AppendUnicodeToObj_TCL_DECLARED
-#define Tcl_AppendUnicodeToObj_TCL_DECLARED
/* 384 */
EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
- CONST Tcl_UniChar *unicode, int length);
-#endif
-#ifndef Tcl_RegExpMatchObj_TCL_DECLARED
-#define Tcl_RegExpMatchObj_TCL_DECLARED
+ const Tcl_UniChar *unicode, int length);
/* 385 */
EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp,
Tcl_Obj *textObj, Tcl_Obj *patternObj);
-#endif
-#ifndef Tcl_SetNotifier_TCL_DECLARED
-#define Tcl_SetNotifier_TCL_DECLARED
/* 386 */
EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr);
-#endif
-#ifndef Tcl_GetAllocMutex_TCL_DECLARED
-#define Tcl_GetAllocMutex_TCL_DECLARED
/* 387 */
EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void);
-#endif
-#ifndef Tcl_GetChannelNames_TCL_DECLARED
-#define Tcl_GetChannelNames_TCL_DECLARED
/* 388 */
EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetChannelNamesEx_TCL_DECLARED
-#define Tcl_GetChannelNamesEx_TCL_DECLARED
/* 389 */
EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp,
- CONST char *pattern);
-#endif
-#ifndef Tcl_ProcObjCmd_TCL_DECLARED
-#define Tcl_ProcObjCmd_TCL_DECLARED
+ const char *pattern);
/* 390 */
EXTERN int Tcl_ProcObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_ConditionFinalize_TCL_DECLARED
-#define Tcl_ConditionFinalize_TCL_DECLARED
+ Tcl_Obj *const objv[]);
/* 391 */
EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr);
-#endif
-#ifndef Tcl_MutexFinalize_TCL_DECLARED
-#define Tcl_MutexFinalize_TCL_DECLARED
/* 392 */
EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex);
-#endif
-#ifndef Tcl_CreateThread_TCL_DECLARED
-#define Tcl_CreateThread_TCL_DECLARED
/* 393 */
EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr,
- Tcl_ThreadCreateProc proc,
+ Tcl_ThreadCreateProc *proc,
ClientData clientData, int stackSize,
int flags);
-#endif
-#ifndef Tcl_ReadRaw_TCL_DECLARED
-#define Tcl_ReadRaw_TCL_DECLARED
/* 394 */
EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst,
int bytesToRead);
-#endif
-#ifndef Tcl_WriteRaw_TCL_DECLARED
-#define Tcl_WriteRaw_TCL_DECLARED
/* 395 */
-EXTERN int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src,
+EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src,
int srcLen);
-#endif
-#ifndef Tcl_GetTopChannel_TCL_DECLARED
-#define Tcl_GetTopChannel_TCL_DECLARED
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
-#endif
-#ifndef Tcl_ChannelBuffered_TCL_DECLARED
-#define Tcl_ChannelBuffered_TCL_DECLARED
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
-#endif
-#ifndef Tcl_ChannelName_TCL_DECLARED
-#define Tcl_ChannelName_TCL_DECLARED
/* 398 */
EXTERN CONST84_RETURN char * Tcl_ChannelName(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelVersion_TCL_DECLARED
-#define Tcl_ChannelVersion_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelBlockModeProc_TCL_DECLARED
-#define Tcl_ChannelBlockModeProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelCloseProc_TCL_DECLARED
-#define Tcl_ChannelCloseProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 401 */
EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelClose2Proc_TCL_DECLARED
-#define Tcl_ChannelClose2Proc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelInputProc_TCL_DECLARED
-#define Tcl_ChannelInputProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 403 */
EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelOutputProc_TCL_DECLARED
-#define Tcl_ChannelOutputProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 404 */
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelSeekProc_TCL_DECLARED
-#define Tcl_ChannelSeekProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 405 */
EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelSetOptionProc_TCL_DECLARED
-#define Tcl_ChannelSetOptionProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelGetOptionProc_TCL_DECLARED
-#define Tcl_ChannelGetOptionProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 407 */
EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelWatchProc_TCL_DECLARED
-#define Tcl_ChannelWatchProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 408 */
EXTERN Tcl_DriverWatchProc * Tcl_ChannelWatchProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelGetHandleProc_TCL_DECLARED
-#define Tcl_ChannelGetHandleProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 409 */
EXTERN Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelFlushProc_TCL_DECLARED
-#define Tcl_ChannelFlushProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 410 */
EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_ChannelHandlerProc_TCL_DECLARED
-#define Tcl_ChannelHandlerProc_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 411 */
EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_JoinThread_TCL_DECLARED
-#define Tcl_JoinThread_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 412 */
EXTERN int Tcl_JoinThread(Tcl_ThreadId threadId, int *result);
-#endif
-#ifndef Tcl_IsChannelShared_TCL_DECLARED
-#define Tcl_IsChannelShared_TCL_DECLARED
/* 413 */
EXTERN int Tcl_IsChannelShared(Tcl_Channel channel);
-#endif
-#ifndef Tcl_IsChannelRegistered_TCL_DECLARED
-#define Tcl_IsChannelRegistered_TCL_DECLARED
/* 414 */
EXTERN int Tcl_IsChannelRegistered(Tcl_Interp *interp,
Tcl_Channel channel);
-#endif
-#ifndef Tcl_CutChannel_TCL_DECLARED
-#define Tcl_CutChannel_TCL_DECLARED
/* 415 */
EXTERN void Tcl_CutChannel(Tcl_Channel channel);
-#endif
-#ifndef Tcl_SpliceChannel_TCL_DECLARED
-#define Tcl_SpliceChannel_TCL_DECLARED
/* 416 */
EXTERN void Tcl_SpliceChannel(Tcl_Channel channel);
-#endif
-#ifndef Tcl_ClearChannelHandlers_TCL_DECLARED
-#define Tcl_ClearChannelHandlers_TCL_DECLARED
/* 417 */
EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel);
-#endif
-#ifndef Tcl_IsChannelExisting_TCL_DECLARED
-#define Tcl_IsChannelExisting_TCL_DECLARED
/* 418 */
-EXTERN int Tcl_IsChannelExisting(CONST char *channelName);
-#endif
-#ifndef Tcl_UniCharNcasecmp_TCL_DECLARED
-#define Tcl_UniCharNcasecmp_TCL_DECLARED
+EXTERN int Tcl_IsChannelExisting(const char *channelName);
/* 419 */
-EXTERN int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs,
- CONST Tcl_UniChar *uct,
+EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
+ const Tcl_UniChar *uct,
unsigned long numChars);
-#endif
-#ifndef Tcl_UniCharCaseMatch_TCL_DECLARED
-#define Tcl_UniCharCaseMatch_TCL_DECLARED
/* 420 */
-EXTERN int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr,
- CONST Tcl_UniChar *uniPattern, int nocase);
-#endif
-#ifndef Tcl_FindHashEntry_TCL_DECLARED
-#define Tcl_FindHashEntry_TCL_DECLARED
+EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
+ const Tcl_UniChar *uniPattern, int nocase);
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr,
- CONST char *key);
-#endif
-#ifndef Tcl_CreateHashEntry_TCL_DECLARED
-#define Tcl_CreateHashEntry_TCL_DECLARED
+ const void *key);
/* 422 */
EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr);
-#endif
-#ifndef Tcl_InitCustomHashTable_TCL_DECLARED
-#define Tcl_InitCustomHashTable_TCL_DECLARED
+ const void *key, int *newPtr);
/* 423 */
EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr,
- int keyType, Tcl_HashKeyType *typePtr);
-#endif
-#ifndef Tcl_InitObjHashTable_TCL_DECLARED
-#define Tcl_InitObjHashTable_TCL_DECLARED
+ int keyType, const Tcl_HashKeyType *typePtr);
/* 424 */
EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr);
-#endif
-#ifndef Tcl_CommandTraceInfo_TCL_DECLARED
-#define Tcl_CommandTraceInfo_TCL_DECLARED
/* 425 */
EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp,
- CONST char *varName, int flags,
+ const char *varName, int flags,
Tcl_CommandTraceProc *procPtr,
ClientData prevClientData);
-#endif
-#ifndef Tcl_TraceCommand_TCL_DECLARED
-#define Tcl_TraceCommand_TCL_DECLARED
/* 426 */
EXTERN int Tcl_TraceCommand(Tcl_Interp *interp,
- CONST char *varName, int flags,
+ const char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_UntraceCommand_TCL_DECLARED
-#define Tcl_UntraceCommand_TCL_DECLARED
/* 427 */
EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp,
- CONST char *varName, int flags,
+ const char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData);
-#endif
-#ifndef Tcl_AttemptAlloc_TCL_DECLARED
-#define Tcl_AttemptAlloc_TCL_DECLARED
/* 428 */
EXTERN char * Tcl_AttemptAlloc(unsigned int size);
-#endif
-#ifndef Tcl_AttemptDbCkalloc_TCL_DECLARED
-#define Tcl_AttemptDbCkalloc_TCL_DECLARED
/* 429 */
EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_AttemptRealloc_TCL_DECLARED
-#define Tcl_AttemptRealloc_TCL_DECLARED
+ const char *file, int line);
/* 430 */
EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size);
-#endif
-#ifndef Tcl_AttemptDbCkrealloc_TCL_DECLARED
-#define Tcl_AttemptDbCkrealloc_TCL_DECLARED
/* 431 */
EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_AttemptSetObjLength_TCL_DECLARED
-#define Tcl_AttemptSetObjLength_TCL_DECLARED
+ const char *file, int line);
/* 432 */
EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length);
-#endif
-#ifndef Tcl_GetChannelThread_TCL_DECLARED
-#define Tcl_GetChannelThread_TCL_DECLARED
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
-#endif
-#ifndef Tcl_GetUnicodeFromObj_TCL_DECLARED
-#define Tcl_GetUnicodeFromObj_TCL_DECLARED
/* 434 */
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
-#endif
-#ifndef Tcl_GetMathFuncInfo_TCL_DECLARED
-#define Tcl_GetMathFuncInfo_TCL_DECLARED
/* 435 */
EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
- CONST char *name, int *numArgsPtr,
+ const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr);
-#endif
-#ifndef Tcl_ListMathFuncs_TCL_DECLARED
-#define Tcl_ListMathFuncs_TCL_DECLARED
/* 436 */
EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
- CONST char *pattern);
-#endif
-#ifndef Tcl_SubstObj_TCL_DECLARED
-#define Tcl_SubstObj_TCL_DECLARED
+ const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
-#endif
-#ifndef Tcl_DetachChannel_TCL_DECLARED
-#define Tcl_DetachChannel_TCL_DECLARED
/* 438 */
EXTERN int Tcl_DetachChannel(Tcl_Interp *interp,
Tcl_Channel channel);
-#endif
-#ifndef Tcl_IsStandardChannel_TCL_DECLARED
-#define Tcl_IsStandardChannel_TCL_DECLARED
/* 439 */
EXTERN int Tcl_IsStandardChannel(Tcl_Channel channel);
-#endif
-#ifndef Tcl_FSCopyFile_TCL_DECLARED
-#define Tcl_FSCopyFile_TCL_DECLARED
/* 440 */
EXTERN int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr);
-#endif
-#ifndef Tcl_FSCopyDirectory_TCL_DECLARED
-#define Tcl_FSCopyDirectory_TCL_DECLARED
/* 441 */
EXTERN int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr);
-#endif
-#ifndef Tcl_FSCreateDirectory_TCL_DECLARED
-#define Tcl_FSCreateDirectory_TCL_DECLARED
/* 442 */
EXTERN int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSDeleteFile_TCL_DECLARED
-#define Tcl_FSDeleteFile_TCL_DECLARED
/* 443 */
EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSLoadFile_TCL_DECLARED
-#define Tcl_FSLoadFile_TCL_DECLARED
/* 444 */
EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
- CONST char *sym1, CONST char *sym2,
+ const char *sym1, const char *sym2,
Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr);
-#endif
-#ifndef Tcl_FSMatchInDirectory_TCL_DECLARED
-#define Tcl_FSMatchInDirectory_TCL_DECLARED
/* 445 */
EXTERN int Tcl_FSMatchInDirectory(Tcl_Interp *interp,
Tcl_Obj *result, Tcl_Obj *pathPtr,
- CONST char *pattern, Tcl_GlobTypeData *types);
-#endif
-#ifndef Tcl_FSLink_TCL_DECLARED
-#define Tcl_FSLink_TCL_DECLARED
+ const char *pattern, Tcl_GlobTypeData *types);
/* 446 */
EXTERN Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
int linkAction);
-#endif
-#ifndef Tcl_FSRemoveDirectory_TCL_DECLARED
-#define Tcl_FSRemoveDirectory_TCL_DECLARED
/* 447 */
EXTERN int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr);
-#endif
-#ifndef Tcl_FSRenameFile_TCL_DECLARED
-#define Tcl_FSRenameFile_TCL_DECLARED
/* 448 */
EXTERN int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr);
-#endif
-#ifndef Tcl_FSLstat_TCL_DECLARED
-#define Tcl_FSLstat_TCL_DECLARED
/* 449 */
EXTERN int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
-#endif
-#ifndef Tcl_FSUtime_TCL_DECLARED
-#define Tcl_FSUtime_TCL_DECLARED
/* 450 */
EXTERN int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
-#endif
-#ifndef Tcl_FSFileAttrsGet_TCL_DECLARED
-#define Tcl_FSFileAttrsGet_TCL_DECLARED
/* 451 */
EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index,
Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
-#endif
-#ifndef Tcl_FSFileAttrsSet_TCL_DECLARED
-#define Tcl_FSFileAttrsSet_TCL_DECLARED
/* 452 */
EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index,
Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_FSFileAttrStrings_TCL_DECLARED
-#define Tcl_FSFileAttrStrings_TCL_DECLARED
/* 453 */
-EXTERN CONST char ** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
+EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef);
-#endif
-#ifndef Tcl_FSStat_TCL_DECLARED
-#define Tcl_FSStat_TCL_DECLARED
/* 454 */
EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
-#endif
-#ifndef Tcl_FSAccess_TCL_DECLARED
-#define Tcl_FSAccess_TCL_DECLARED
/* 455 */
EXTERN int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode);
-#endif
-#ifndef Tcl_FSOpenFileChannel_TCL_DECLARED
-#define Tcl_FSOpenFileChannel_TCL_DECLARED
/* 456 */
EXTERN Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp,
- Tcl_Obj *pathPtr, CONST char *modeString,
+ Tcl_Obj *pathPtr, const char *modeString,
int permissions);
-#endif
-#ifndef Tcl_FSGetCwd_TCL_DECLARED
-#define Tcl_FSGetCwd_TCL_DECLARED
/* 457 */
EXTERN Tcl_Obj * Tcl_FSGetCwd(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_FSChdir_TCL_DECLARED
-#define Tcl_FSChdir_TCL_DECLARED
/* 458 */
EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSConvertToPathType_TCL_DECLARED
-#define Tcl_FSConvertToPathType_TCL_DECLARED
/* 459 */
EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSJoinPath_TCL_DECLARED
-#define Tcl_FSJoinPath_TCL_DECLARED
/* 460 */
EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, int elements);
-#endif
-#ifndef Tcl_FSSplitPath_TCL_DECLARED
-#define Tcl_FSSplitPath_TCL_DECLARED
/* 461 */
EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
-#endif
-#ifndef Tcl_FSEqualPaths_TCL_DECLARED
-#define Tcl_FSEqualPaths_TCL_DECLARED
/* 462 */
EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr);
-#endif
-#ifndef Tcl_FSGetNormalizedPath_TCL_DECLARED
-#define Tcl_FSGetNormalizedPath_TCL_DECLARED
/* 463 */
EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSJoinToPath_TCL_DECLARED
-#define Tcl_FSJoinToPath_TCL_DECLARED
/* 464 */
EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_FSGetInternalRep_TCL_DECLARED
-#define Tcl_FSGetInternalRep_TCL_DECLARED
+ Tcl_Obj *const objv[]);
/* 465 */
EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
- Tcl_Filesystem *fsPtr);
-#endif
-#ifndef Tcl_FSGetTranslatedPath_TCL_DECLARED
-#define Tcl_FSGetTranslatedPath_TCL_DECLARED
+ const Tcl_Filesystem *fsPtr);
/* 466 */
EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSEvalFile_TCL_DECLARED
-#define Tcl_FSEvalFile_TCL_DECLARED
/* 467 */
EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName);
-#endif
-#ifndef Tcl_FSNewNativePath_TCL_DECLARED
-#define Tcl_FSNewNativePath_TCL_DECLARED
/* 468 */
-EXTERN Tcl_Obj * Tcl_FSNewNativePath(Tcl_Filesystem *fromFilesystem,
+EXTERN Tcl_Obj * Tcl_FSNewNativePath(
+ const Tcl_Filesystem *fromFilesystem,
ClientData clientData);
-#endif
-#ifndef Tcl_FSGetNativePath_TCL_DECLARED
-#define Tcl_FSGetNativePath_TCL_DECLARED
/* 469 */
-EXTERN CONST char * Tcl_FSGetNativePath(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSFileSystemInfo_TCL_DECLARED
-#define Tcl_FSFileSystemInfo_TCL_DECLARED
+EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr);
/* 470 */
EXTERN Tcl_Obj * Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSPathSeparator_TCL_DECLARED
-#define Tcl_FSPathSeparator_TCL_DECLARED
/* 471 */
EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSListVolumes_TCL_DECLARED
-#define Tcl_FSListVolumes_TCL_DECLARED
/* 472 */
EXTERN Tcl_Obj * Tcl_FSListVolumes(void);
-#endif
-#ifndef Tcl_FSRegister_TCL_DECLARED
-#define Tcl_FSRegister_TCL_DECLARED
/* 473 */
EXTERN int Tcl_FSRegister(ClientData clientData,
- Tcl_Filesystem *fsPtr);
-#endif
-#ifndef Tcl_FSUnregister_TCL_DECLARED
-#define Tcl_FSUnregister_TCL_DECLARED
+ const Tcl_Filesystem *fsPtr);
/* 474 */
-EXTERN int Tcl_FSUnregister(Tcl_Filesystem *fsPtr);
-#endif
-#ifndef Tcl_FSData_TCL_DECLARED
-#define Tcl_FSData_TCL_DECLARED
+EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr);
/* 475 */
-EXTERN ClientData Tcl_FSData(Tcl_Filesystem *fsPtr);
-#endif
-#ifndef Tcl_FSGetTranslatedStringPath_TCL_DECLARED
-#define Tcl_FSGetTranslatedStringPath_TCL_DECLARED
+EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr);
/* 476 */
-EXTERN CONST char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
+EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSGetFileSystemForPath_TCL_DECLARED
-#define Tcl_FSGetFileSystemForPath_TCL_DECLARED
/* 477 */
-EXTERN Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_FSGetPathType_TCL_DECLARED
-#define Tcl_FSGetPathType_TCL_DECLARED
+EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr);
/* 478 */
EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr);
-#endif
-#ifndef Tcl_OutputBuffered_TCL_DECLARED
-#define Tcl_OutputBuffered_TCL_DECLARED
/* 479 */
EXTERN int Tcl_OutputBuffered(Tcl_Channel chan);
-#endif
-#ifndef Tcl_FSMountsChanged_TCL_DECLARED
-#define Tcl_FSMountsChanged_TCL_DECLARED
/* 480 */
-EXTERN void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr);
-#endif
-#ifndef Tcl_EvalTokensStandard_TCL_DECLARED
-#define Tcl_EvalTokensStandard_TCL_DECLARED
+EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr);
/* 481 */
EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
-#endif
-#ifndef Tcl_GetTime_TCL_DECLARED
-#define Tcl_GetTime_TCL_DECLARED
/* 482 */
EXTERN void Tcl_GetTime(Tcl_Time *timeBuf);
-#endif
-#ifndef Tcl_CreateObjTrace_TCL_DECLARED
-#define Tcl_CreateObjTrace_TCL_DECLARED
/* 483 */
EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level,
int flags, Tcl_CmdObjTraceProc *objProc,
ClientData clientData,
Tcl_CmdObjTraceDeleteProc *delProc);
-#endif
-#ifndef Tcl_GetCommandInfoFromToken_TCL_DECLARED
-#define Tcl_GetCommandInfoFromToken_TCL_DECLARED
/* 484 */
EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token,
Tcl_CmdInfo *infoPtr);
-#endif
-#ifndef Tcl_SetCommandInfoFromToken_TCL_DECLARED
-#define Tcl_SetCommandInfoFromToken_TCL_DECLARED
/* 485 */
EXTERN int Tcl_SetCommandInfoFromToken(Tcl_Command token,
- CONST Tcl_CmdInfo *infoPtr);
-#endif
-#ifndef Tcl_DbNewWideIntObj_TCL_DECLARED
-#define Tcl_DbNewWideIntObj_TCL_DECLARED
+ const Tcl_CmdInfo *infoPtr);
/* 486 */
EXTERN Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue,
- CONST char *file, int line);
-#endif
-#ifndef Tcl_GetWideIntFromObj_TCL_DECLARED
-#define Tcl_GetWideIntFromObj_TCL_DECLARED
+ const char *file, int line);
/* 487 */
EXTERN int Tcl_GetWideIntFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
-#endif
-#ifndef Tcl_NewWideIntObj_TCL_DECLARED
-#define Tcl_NewWideIntObj_TCL_DECLARED
/* 488 */
EXTERN Tcl_Obj * Tcl_NewWideIntObj(Tcl_WideInt wideValue);
-#endif
-#ifndef Tcl_SetWideIntObj_TCL_DECLARED
-#define Tcl_SetWideIntObj_TCL_DECLARED
/* 489 */
EXTERN void Tcl_SetWideIntObj(Tcl_Obj *objPtr,
Tcl_WideInt wideValue);
-#endif
-#ifndef Tcl_AllocStatBuf_TCL_DECLARED
-#define Tcl_AllocStatBuf_TCL_DECLARED
/* 490 */
EXTERN Tcl_StatBuf * Tcl_AllocStatBuf(void);
-#endif
-#ifndef Tcl_Seek_TCL_DECLARED
-#define Tcl_Seek_TCL_DECLARED
/* 491 */
EXTERN Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset,
int mode);
-#endif
-#ifndef Tcl_Tell_TCL_DECLARED
-#define Tcl_Tell_TCL_DECLARED
/* 492 */
EXTERN Tcl_WideInt Tcl_Tell(Tcl_Channel chan);
-#endif
-#ifndef Tcl_ChannelWideSeekProc_TCL_DECLARED
-#define Tcl_ChannelWideSeekProc_TCL_DECLARED
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_DictObjPut_TCL_DECLARED
-#define Tcl_DictObjPut_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 494 */
EXTERN int Tcl_DictObjPut(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr, Tcl_Obj *valuePtr);
-#endif
-#ifndef Tcl_DictObjGet_TCL_DECLARED
-#define Tcl_DictObjGet_TCL_DECLARED
/* 495 */
EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr);
-#endif
-#ifndef Tcl_DictObjRemove_TCL_DECLARED
-#define Tcl_DictObjRemove_TCL_DECLARED
/* 496 */
EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp,
Tcl_Obj *dictPtr, Tcl_Obj *keyPtr);
-#endif
-#ifndef Tcl_DictObjSize_TCL_DECLARED
-#define Tcl_DictObjSize_TCL_DECLARED
/* 497 */
EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
int *sizePtr);
-#endif
-#ifndef Tcl_DictObjFirst_TCL_DECLARED
-#define Tcl_DictObjFirst_TCL_DECLARED
/* 498 */
EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp,
Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr,
int *donePtr);
-#endif
-#ifndef Tcl_DictObjNext_TCL_DECLARED
-#define Tcl_DictObjNext_TCL_DECLARED
/* 499 */
EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr,
int *donePtr);
-#endif
-#ifndef Tcl_DictObjDone_TCL_DECLARED
-#define Tcl_DictObjDone_TCL_DECLARED
/* 500 */
EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr);
-#endif
-#ifndef Tcl_DictObjPutKeyList_TCL_DECLARED
-#define Tcl_DictObjPutKeyList_TCL_DECLARED
/* 501 */
EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp,
Tcl_Obj *dictPtr, int keyc,
- Tcl_Obj *CONST *keyv, Tcl_Obj *valuePtr);
-#endif
-#ifndef Tcl_DictObjRemoveKeyList_TCL_DECLARED
-#define Tcl_DictObjRemoveKeyList_TCL_DECLARED
+ Tcl_Obj *const *keyv, Tcl_Obj *valuePtr);
/* 502 */
EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp,
Tcl_Obj *dictPtr, int keyc,
- Tcl_Obj *CONST *keyv);
-#endif
-#ifndef Tcl_NewDictObj_TCL_DECLARED
-#define Tcl_NewDictObj_TCL_DECLARED
+ Tcl_Obj *const *keyv);
/* 503 */
EXTERN Tcl_Obj * Tcl_NewDictObj(void);
-#endif
-#ifndef Tcl_DbNewDictObj_TCL_DECLARED
-#define Tcl_DbNewDictObj_TCL_DECLARED
/* 504 */
-EXTERN Tcl_Obj * Tcl_DbNewDictObj(CONST char *file, int line);
-#endif
-#ifndef Tcl_RegisterConfig_TCL_DECLARED
-#define Tcl_RegisterConfig_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_DbNewDictObj(const char *file, int line);
/* 505 */
EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp,
- CONST char *pkgName,
- Tcl_Config *configuration,
- CONST char *valEncoding);
-#endif
-#ifndef Tcl_CreateNamespace_TCL_DECLARED
-#define Tcl_CreateNamespace_TCL_DECLARED
+ const char *pkgName,
+ const Tcl_Config *configuration,
+ const char *valEncoding);
/* 506 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- CONST char *name, ClientData clientData,
+ const char *name, ClientData clientData,
Tcl_NamespaceDeleteProc *deleteProc);
-#endif
-#ifndef Tcl_DeleteNamespace_TCL_DECLARED
-#define Tcl_DeleteNamespace_TCL_DECLARED
/* 507 */
EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
-#endif
-#ifndef Tcl_AppendExportList_TCL_DECLARED
-#define Tcl_AppendExportList_TCL_DECLARED
/* 508 */
EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_Export_TCL_DECLARED
-#define Tcl_Export_TCL_DECLARED
/* 509 */
EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int resetListFirst);
-#endif
-#ifndef Tcl_Import_TCL_DECLARED
-#define Tcl_Import_TCL_DECLARED
+ const char *pattern, int resetListFirst);
/* 510 */
EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int allowOverwrite);
-#endif
-#ifndef Tcl_ForgetImport_TCL_DECLARED
-#define Tcl_ForgetImport_TCL_DECLARED
+ const char *pattern, int allowOverwrite);
/* 511 */
EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
- Tcl_Namespace *nsPtr, CONST char *pattern);
-#endif
-#ifndef Tcl_GetCurrentNamespace_TCL_DECLARED
-#define Tcl_GetCurrentNamespace_TCL_DECLARED
+ Tcl_Namespace *nsPtr, const char *pattern);
/* 512 */
EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetGlobalNamespace_TCL_DECLARED
-#define Tcl_GetGlobalNamespace_TCL_DECLARED
/* 513 */
EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_FindNamespace_TCL_DECLARED
-#define Tcl_FindNamespace_TCL_DECLARED
/* 514 */
EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-#endif
-#ifndef Tcl_FindCommand_TCL_DECLARED
-#define Tcl_FindCommand_TCL_DECLARED
/* 515 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name,
+EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-#endif
-#ifndef Tcl_GetCommandFromObj_TCL_DECLARED
-#define Tcl_GetCommandFromObj_TCL_DECLARED
/* 516 */
EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetCommandFullName_TCL_DECLARED
-#define Tcl_GetCommandFullName_TCL_DECLARED
/* 517 */
EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_FSEvalFileEx_TCL_DECLARED
-#define Tcl_FSEvalFileEx_TCL_DECLARED
/* 518 */
EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp,
- Tcl_Obj *fileName, CONST char *encodingName);
-#endif
-#ifndef Tcl_SetExitProc_TCL_DECLARED
-#define Tcl_SetExitProc_TCL_DECLARED
+ Tcl_Obj *fileName, const char *encodingName);
/* 519 */
EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc);
-#endif
-#ifndef Tcl_LimitAddHandler_TCL_DECLARED
-#define Tcl_LimitAddHandler_TCL_DECLARED
/* 520 */
EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
ClientData clientData,
Tcl_LimitHandlerDeleteProc *deleteProc);
-#endif
-#ifndef Tcl_LimitRemoveHandler_TCL_DECLARED
-#define Tcl_LimitRemoveHandler_TCL_DECLARED
/* 521 */
EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
ClientData clientData);
-#endif
-#ifndef Tcl_LimitReady_TCL_DECLARED
-#define Tcl_LimitReady_TCL_DECLARED
/* 522 */
EXTERN int Tcl_LimitReady(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_LimitCheck_TCL_DECLARED
-#define Tcl_LimitCheck_TCL_DECLARED
/* 523 */
EXTERN int Tcl_LimitCheck(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_LimitExceeded_TCL_DECLARED
-#define Tcl_LimitExceeded_TCL_DECLARED
/* 524 */
EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_LimitSetCommands_TCL_DECLARED
-#define Tcl_LimitSetCommands_TCL_DECLARED
/* 525 */
EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp,
int commandLimit);
-#endif
-#ifndef Tcl_LimitSetTime_TCL_DECLARED
-#define Tcl_LimitSetTime_TCL_DECLARED
/* 526 */
EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp,
Tcl_Time *timeLimitPtr);
-#endif
-#ifndef Tcl_LimitSetGranularity_TCL_DECLARED
-#define Tcl_LimitSetGranularity_TCL_DECLARED
/* 527 */
EXTERN void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type,
int granularity);
-#endif
-#ifndef Tcl_LimitTypeEnabled_TCL_DECLARED
-#define Tcl_LimitTypeEnabled_TCL_DECLARED
/* 528 */
EXTERN int Tcl_LimitTypeEnabled(Tcl_Interp *interp, int type);
-#endif
-#ifndef Tcl_LimitTypeExceeded_TCL_DECLARED
-#define Tcl_LimitTypeExceeded_TCL_DECLARED
/* 529 */
EXTERN int Tcl_LimitTypeExceeded(Tcl_Interp *interp, int type);
-#endif
-#ifndef Tcl_LimitTypeSet_TCL_DECLARED
-#define Tcl_LimitTypeSet_TCL_DECLARED
/* 530 */
EXTERN void Tcl_LimitTypeSet(Tcl_Interp *interp, int type);
-#endif
-#ifndef Tcl_LimitTypeReset_TCL_DECLARED
-#define Tcl_LimitTypeReset_TCL_DECLARED
/* 531 */
EXTERN void Tcl_LimitTypeReset(Tcl_Interp *interp, int type);
-#endif
-#ifndef Tcl_LimitGetCommands_TCL_DECLARED
-#define Tcl_LimitGetCommands_TCL_DECLARED
/* 532 */
EXTERN int Tcl_LimitGetCommands(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_LimitGetTime_TCL_DECLARED
-#define Tcl_LimitGetTime_TCL_DECLARED
/* 533 */
EXTERN void Tcl_LimitGetTime(Tcl_Interp *interp,
Tcl_Time *timeLimitPtr);
-#endif
-#ifndef Tcl_LimitGetGranularity_TCL_DECLARED
-#define Tcl_LimitGetGranularity_TCL_DECLARED
/* 534 */
EXTERN int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type);
-#endif
-#ifndef Tcl_SaveInterpState_TCL_DECLARED
-#define Tcl_SaveInterpState_TCL_DECLARED
/* 535 */
EXTERN Tcl_InterpState Tcl_SaveInterpState(Tcl_Interp *interp, int status);
-#endif
-#ifndef Tcl_RestoreInterpState_TCL_DECLARED
-#define Tcl_RestoreInterpState_TCL_DECLARED
/* 536 */
EXTERN int Tcl_RestoreInterpState(Tcl_Interp *interp,
Tcl_InterpState state);
-#endif
-#ifndef Tcl_DiscardInterpState_TCL_DECLARED
-#define Tcl_DiscardInterpState_TCL_DECLARED
/* 537 */
EXTERN void Tcl_DiscardInterpState(Tcl_InterpState state);
-#endif
-#ifndef Tcl_SetReturnOptions_TCL_DECLARED
-#define Tcl_SetReturnOptions_TCL_DECLARED
/* 538 */
EXTERN int Tcl_SetReturnOptions(Tcl_Interp *interp,
Tcl_Obj *options);
-#endif
-#ifndef Tcl_GetReturnOptions_TCL_DECLARED
-#define Tcl_GetReturnOptions_TCL_DECLARED
/* 539 */
EXTERN Tcl_Obj * Tcl_GetReturnOptions(Tcl_Interp *interp, int result);
-#endif
-#ifndef Tcl_IsEnsemble_TCL_DECLARED
-#define Tcl_IsEnsemble_TCL_DECLARED
/* 540 */
EXTERN int Tcl_IsEnsemble(Tcl_Command token);
-#endif
-#ifndef Tcl_CreateEnsemble_TCL_DECLARED
-#define Tcl_CreateEnsemble_TCL_DECLARED
/* 541 */
EXTERN Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_Namespace *namespacePtr, int flags);
-#endif
-#ifndef Tcl_FindEnsemble_TCL_DECLARED
-#define Tcl_FindEnsemble_TCL_DECLARED
/* 542 */
EXTERN Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp,
Tcl_Obj *cmdNameObj, int flags);
-#endif
-#ifndef Tcl_SetEnsembleSubcommandList_TCL_DECLARED
-#define Tcl_SetEnsembleSubcommandList_TCL_DECLARED
/* 543 */
EXTERN int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj *subcmdList);
-#endif
-#ifndef Tcl_SetEnsembleMappingDict_TCL_DECLARED
-#define Tcl_SetEnsembleMappingDict_TCL_DECLARED
/* 544 */
EXTERN int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj *mapDict);
-#endif
-#ifndef Tcl_SetEnsembleUnknownHandler_TCL_DECLARED
-#define Tcl_SetEnsembleUnknownHandler_TCL_DECLARED
/* 545 */
EXTERN int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj *unknownList);
-#endif
-#ifndef Tcl_SetEnsembleFlags_TCL_DECLARED
-#define Tcl_SetEnsembleFlags_TCL_DECLARED
/* 546 */
EXTERN int Tcl_SetEnsembleFlags(Tcl_Interp *interp,
Tcl_Command token, int flags);
-#endif
-#ifndef Tcl_GetEnsembleSubcommandList_TCL_DECLARED
-#define Tcl_GetEnsembleSubcommandList_TCL_DECLARED
/* 547 */
EXTERN int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj **subcmdListPtr);
-#endif
-#ifndef Tcl_GetEnsembleMappingDict_TCL_DECLARED
-#define Tcl_GetEnsembleMappingDict_TCL_DECLARED
/* 548 */
EXTERN int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj **mapDictPtr);
-#endif
-#ifndef Tcl_GetEnsembleUnknownHandler_TCL_DECLARED
-#define Tcl_GetEnsembleUnknownHandler_TCL_DECLARED
/* 549 */
EXTERN int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp,
Tcl_Command token, Tcl_Obj **unknownListPtr);
-#endif
-#ifndef Tcl_GetEnsembleFlags_TCL_DECLARED
-#define Tcl_GetEnsembleFlags_TCL_DECLARED
/* 550 */
EXTERN int Tcl_GetEnsembleFlags(Tcl_Interp *interp,
Tcl_Command token, int *flagsPtr);
-#endif
-#ifndef Tcl_GetEnsembleNamespace_TCL_DECLARED
-#define Tcl_GetEnsembleNamespace_TCL_DECLARED
/* 551 */
EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp,
Tcl_Command token,
Tcl_Namespace **namespacePtrPtr);
-#endif
-#ifndef Tcl_SetTimeProc_TCL_DECLARED
-#define Tcl_SetTimeProc_TCL_DECLARED
/* 552 */
EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
ClientData clientData);
-#endif
-#ifndef Tcl_QueryTimeProc_TCL_DECLARED
-#define Tcl_QueryTimeProc_TCL_DECLARED
/* 553 */
EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
ClientData *clientData);
-#endif
-#ifndef Tcl_ChannelThreadActionProc_TCL_DECLARED
-#define Tcl_ChannelThreadActionProc_TCL_DECLARED
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_NewBignumObj_TCL_DECLARED
-#define Tcl_NewBignumObj_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 555 */
EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value);
-#endif
-#ifndef Tcl_DbNewBignumObj_TCL_DECLARED
-#define Tcl_DbNewBignumObj_TCL_DECLARED
/* 556 */
-EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, CONST char *file,
+EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, const char *file,
int line);
-#endif
-#ifndef Tcl_SetBignumObj_TCL_DECLARED
-#define Tcl_SetBignumObj_TCL_DECLARED
/* 557 */
EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value);
-#endif
-#ifndef Tcl_GetBignumFromObj_TCL_DECLARED
-#define Tcl_GetBignumFromObj_TCL_DECLARED
/* 558 */
EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp,
Tcl_Obj *obj, mp_int *value);
-#endif
-#ifndef Tcl_TakeBignumFromObj_TCL_DECLARED
-#define Tcl_TakeBignumFromObj_TCL_DECLARED
/* 559 */
EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp,
Tcl_Obj *obj, mp_int *value);
-#endif
-#ifndef Tcl_TruncateChannel_TCL_DECLARED
-#define Tcl_TruncateChannel_TCL_DECLARED
/* 560 */
EXTERN int Tcl_TruncateChannel(Tcl_Channel chan,
Tcl_WideInt length);
-#endif
-#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED
-#define Tcl_ChannelTruncateProc_TCL_DECLARED
/* 561 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc(
- CONST Tcl_ChannelType *chanTypePtr);
-#endif
-#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED
-#define Tcl_SetChannelErrorInterp_TCL_DECLARED
+ const Tcl_ChannelType *chanTypePtr);
/* 562 */
EXTERN void Tcl_SetChannelErrorInterp(Tcl_Interp *interp,
Tcl_Obj *msg);
-#endif
-#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED
-#define Tcl_GetChannelErrorInterp_TCL_DECLARED
/* 563 */
EXTERN void Tcl_GetChannelErrorInterp(Tcl_Interp *interp,
Tcl_Obj **msg);
-#endif
-#ifndef Tcl_SetChannelError_TCL_DECLARED
-#define Tcl_SetChannelError_TCL_DECLARED
/* 564 */
EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg);
-#endif
-#ifndef Tcl_GetChannelError_TCL_DECLARED
-#define Tcl_GetChannelError_TCL_DECLARED
/* 565 */
EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg);
-#endif
-#ifndef Tcl_InitBignumFromDouble_TCL_DECLARED
-#define Tcl_InitBignumFromDouble_TCL_DECLARED
/* 566 */
EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp,
double initval, mp_int *toInit);
-#endif
-#ifndef Tcl_GetNamespaceUnknownHandler_TCL_DECLARED
-#define Tcl_GetNamespaceUnknownHandler_TCL_DECLARED
/* 567 */
EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr);
-#endif
-#ifndef Tcl_SetNamespaceUnknownHandler_TCL_DECLARED
-#define Tcl_SetNamespaceUnknownHandler_TCL_DECLARED
/* 568 */
EXTERN int Tcl_SetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr);
-#endif
-#ifndef Tcl_GetEncodingFromObj_TCL_DECLARED
-#define Tcl_GetEncodingFromObj_TCL_DECLARED
/* 569 */
EXTERN int Tcl_GetEncodingFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
-#endif
-#ifndef Tcl_GetEncodingSearchPath_TCL_DECLARED
-#define Tcl_GetEncodingSearchPath_TCL_DECLARED
/* 570 */
EXTERN Tcl_Obj * Tcl_GetEncodingSearchPath(void);
-#endif
-#ifndef Tcl_SetEncodingSearchPath_TCL_DECLARED
-#define Tcl_SetEncodingSearchPath_TCL_DECLARED
/* 571 */
EXTERN int Tcl_SetEncodingSearchPath(Tcl_Obj *searchPath);
-#endif
-#ifndef Tcl_GetEncodingNameFromEnvironment_TCL_DECLARED
-#define Tcl_GetEncodingNameFromEnvironment_TCL_DECLARED
/* 572 */
-EXTERN CONST char * Tcl_GetEncodingNameFromEnvironment(
+EXTERN const char * Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr);
-#endif
-#ifndef Tcl_PkgRequireProc_TCL_DECLARED
-#define Tcl_PkgRequireProc_TCL_DECLARED
/* 573 */
EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp,
- CONST char *name, int objc,
- Tcl_Obj *CONST objv[],
- ClientData *clientDataPtr);
-#endif
-#ifndef Tcl_AppendObjToErrorInfo_TCL_DECLARED
-#define Tcl_AppendObjToErrorInfo_TCL_DECLARED
+ const char *name, int objc,
+ Tcl_Obj *const objv[], void *clientDataPtr);
/* 574 */
EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_AppendLimitedToObj_TCL_DECLARED
-#define Tcl_AppendLimitedToObj_TCL_DECLARED
/* 575 */
EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr,
- CONST char *bytes, int length, int limit,
- CONST char *ellipsis);
-#endif
-#ifndef Tcl_Format_TCL_DECLARED
-#define Tcl_Format_TCL_DECLARED
+ const char *bytes, int length, int limit,
+ const char *ellipsis);
/* 576 */
-EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, CONST char *format,
- int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_AppendFormatToObj_TCL_DECLARED
-#define Tcl_AppendFormatToObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format,
+ int objc, Tcl_Obj *const objv[]);
/* 577 */
EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr, CONST char *format,
- int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef Tcl_ObjPrintf_TCL_DECLARED
-#define Tcl_ObjPrintf_TCL_DECLARED
+ Tcl_Obj *objPtr, const char *format,
+ int objc, Tcl_Obj *const objv[]);
/* 578 */
-EXTERN Tcl_Obj * Tcl_ObjPrintf(CONST char *format, ...);
-#endif
-#ifndef Tcl_AppendPrintfToObj_TCL_DECLARED
-#define Tcl_AppendPrintfToObj_TCL_DECLARED
+EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
/* 579 */
EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr,
- CONST char *format, ...);
-#endif
+ const char *format, ...) TCL_FORMAT_PRINTF(2, 3);
+/* 580 */
+EXTERN int Tcl_CancelEval(Tcl_Interp *interp,
+ Tcl_Obj *resultObjPtr, ClientData clientData,
+ int flags);
+/* 581 */
+EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags);
+/* 582 */
+EXTERN int Tcl_CreatePipe(Tcl_Interp *interp,
+ Tcl_Channel *rchan, Tcl_Channel *wchan,
+ int flags);
+/* 583 */
+EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 584 */
+EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags);
+/* 585 */
+EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags);
+/* 586 */
+EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd,
+ int objc, Tcl_Obj *const objv[], int flags);
+/* 587 */
+EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp,
+ Tcl_NRPostProc *postProcPtr,
+ ClientData data0, ClientData data1,
+ ClientData data2, ClientData data3);
+/* 588 */
+EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp,
+ Tcl_ObjCmdProc *objProc,
+ ClientData clientData, int objc,
+ Tcl_Obj *const objv[]);
+/* 589 */
+EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr);
+/* 590 */
+EXTERN unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr);
+/* 591 */
+EXTERN unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr);
+/* 592 */
+EXTERN int Tcl_GetLinkCountFromStat(const Tcl_StatBuf *statPtr);
+/* 593 */
+EXTERN int Tcl_GetUserIdFromStat(const Tcl_StatBuf *statPtr);
+/* 594 */
+EXTERN int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr);
+/* 595 */
+EXTERN int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr);
+/* 596 */
+EXTERN Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr);
+/* 597 */
+EXTERN Tcl_WideInt Tcl_GetModificationTimeFromStat(
+ const Tcl_StatBuf *statPtr);
+/* 598 */
+EXTERN Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr);
+/* 599 */
+EXTERN Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr);
+/* 600 */
+EXTERN Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr);
+/* 601 */
+EXTERN unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr);
+/* 602 */
+EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp,
+ Tcl_Command token, Tcl_Obj *paramList);
+/* 603 */
+EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp,
+ Tcl_Command token, Tcl_Obj **paramListPtr);
+/* 604 */
+EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable, int *objcPtr,
+ Tcl_Obj *const *objv, Tcl_Obj ***remObjv);
+/* 605 */
+EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp);
+/* 606 */
+EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum);
+/* 607 */
+EXTERN void Tcl_TransferResult(Tcl_Interp *sourceInterp,
+ int result, Tcl_Interp *targetInterp);
+/* 608 */
+EXTERN int Tcl_InterpActive(Tcl_Interp *interp);
+/* 609 */
+EXTERN void Tcl_BackgroundException(Tcl_Interp *interp, int code);
+/* 610 */
+EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format,
+ Tcl_Obj *data, int level,
+ Tcl_Obj *gzipHeaderDictObj);
+/* 611 */
+EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format,
+ Tcl_Obj *data, int buffersize,
+ Tcl_Obj *gzipHeaderDictObj);
+/* 612 */
+EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc,
+ const unsigned char *buf, int len);
+/* 613 */
+EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler,
+ const unsigned char *buf, int len);
+/* 614 */
+EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode,
+ int format, int level, Tcl_Obj *dictObj,
+ Tcl_ZlibStream *zshandle);
+/* 615 */
+EXTERN Tcl_Obj * Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle);
+/* 616 */
+EXTERN int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle);
+/* 617 */
+EXTERN int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle);
+/* 618 */
+EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle,
+ Tcl_Obj *data, int flush);
+/* 619 */
+EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle,
+ Tcl_Obj *data, int count);
+/* 620 */
+EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle);
+/* 621 */
+EXTERN int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle);
+/* 622 */
+EXTERN void Tcl_SetStartupScript(Tcl_Obj *path,
+ const char *encoding);
+/* 623 */
+EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingPtr);
+/* 624 */
+EXTERN int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan,
+ int flags);
+/* 625 */
+EXTERN int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Obj *resultPtr);
+/* 626 */
+EXTERN int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags);
+/* 627 */
+EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ const char *const symv[], int flags,
+ void *procPtrs, Tcl_LoadHandle *handlePtr);
+/* 628 */
+EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle handle, const char *symbol);
+/* 629 */
+EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
+ Tcl_LoadHandle handlePtr);
typedef struct TclStubHooks {
- struct TclPlatStubs *tclPlatStubs;
- struct TclIntStubs *tclIntStubs;
- struct TclIntPlatStubs *tclIntPlatStubs;
+ const struct TclPlatStubs *tclPlatStubs;
+ const struct TclIntStubs *tclIntStubs;
+ const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
typedef struct TclStubs {
int magic;
- struct TclStubHooks *hooks;
+ const struct TclStubHooks *hooks;
- int (*tcl_PkgProvideEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, ClientData clientData); /* 0 */
- CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr); /* 1 */
- void (*tcl_Panic) (CONST char *format, ...); /* 2 */
+ int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
+ CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
+ void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
char * (*tcl_Alloc) (unsigned int size); /* 3 */
void (*tcl_Free) (char *ptr); /* 4 */
char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
- char * (*tcl_DbCkalloc) (unsigned int size, CONST char *file, int line); /* 6 */
- int (*tcl_DbCkfree) (char *ptr, CONST char *file, int line); /* 7 */
- char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, CONST char *file, int line); /* 8 */
+ char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */
+ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */
+ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- VOID *reserved9;
+ void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
@@ -3441,41 +1840,41 @@ typedef struct TclStubs {
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- VOID *reserved10;
+ void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* MACOSX */
- void (*tcl_SetTimer) (Tcl_Time *timePtr); /* 11 */
+ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
void (*tcl_Sleep) (int ms); /* 12 */
- int (*tcl_WaitForEvent) (Tcl_Time *timePtr); /* 13 */
+ int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */
int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */
void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */
- void (*tcl_AppendToObj) (Tcl_Obj *objPtr, CONST char *bytes, int length); /* 16 */
- Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *CONST objv[]); /* 17 */
- int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_ObjType *typePtr); /* 18 */
- void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, CONST char *file, int line); /* 19 */
- void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, CONST char *file, int line); /* 20 */
- int (*tcl_DbIsShared) (Tcl_Obj *objPtr, CONST char *file, int line); /* 21 */
- Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, CONST char *file, int line); /* 22 */
- Tcl_Obj * (*tcl_DbNewByteArrayObj) (CONST unsigned char *bytes, int length, CONST char *file, int line); /* 23 */
- Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, CONST char *file, int line); /* 24 */
- Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *CONST *objv, CONST char *file, int line); /* 25 */
- Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, CONST char *file, int line); /* 26 */
- Tcl_Obj * (*tcl_DbNewObj) (CONST char *file, int line); /* 27 */
- Tcl_Obj * (*tcl_DbNewStringObj) (CONST char *bytes, int length, CONST char *file, int line); /* 28 */
+ void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 16 */
+ Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */
+ int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */
+ void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
+ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
+ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
+ Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
+ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
+ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
+ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
+ Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
+ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
+ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */
- int (*tcl_GetBoolean) (Tcl_Interp *interp, CONST char *src, int *boolPtr); /* 31 */
+ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */
int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
- int (*tcl_GetDouble) (Tcl_Interp *interp, CONST char *src, double *doublePtr); /* 34 */
+ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
- int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr); /* 36 */
- int (*tcl_GetInt) (Tcl_Interp *interp, CONST char *src, int *intPtr); /* 37 */
+ int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
- Tcl_ObjType * (*tcl_GetObjType) (CONST char *typeName); /* 40 */
+ CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */
char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */
void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */
int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */
@@ -3483,28 +1882,28 @@ typedef struct TclStubs {
int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
- int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[]); /* 48 */
+ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */
Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
- Tcl_Obj * (*tcl_NewByteArrayObj) (CONST unsigned char *bytes, int length); /* 50 */
+ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
- Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *CONST objv[]); /* 53 */
+ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */
Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
- Tcl_Obj * (*tcl_NewStringObj) (CONST char *bytes, int length); /* 56 */
+ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */
- void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, CONST unsigned char *bytes, int length); /* 59 */
+ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
- void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]); /* 62 */
+ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */
void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */
- void (*tcl_SetStringObj) (Tcl_Obj *objPtr, CONST char *bytes, int length); /* 65 */
- void (*tcl_AddErrorInfo) (Tcl_Interp *interp, CONST char *message); /* 66 */
- void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, CONST char *message, int length); /* 67 */
+ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */
+ void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
+ void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */
- void (*tcl_AppendElement) (Tcl_Interp *interp, CONST char *element); /* 69 */
+ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */
void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */
@@ -3512,33 +1911,33 @@ typedef struct TclStubs {
void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */
int (*tcl_AsyncReady) (void); /* 75 */
void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
- char (*tcl_Backslash) (CONST char *src, int *readPtr); /* 77 */
- int (*tcl_BadChannelOption) (Tcl_Interp *interp, CONST char *optionName, CONST char *optionList); /* 78 */
+ char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
+ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
- int (*tcl_CommandComplete) (CONST char *cmd); /* 82 */
- char * (*tcl_Concat) (int argc, CONST84 char *CONST *argv); /* 83 */
- int (*tcl_ConvertElement) (CONST char *src, char *dst, int flags); /* 84 */
- int (*tcl_ConvertCountedElement) (CONST char *src, int length, char *dst, int flags); /* 85 */
- int (*tcl_CreateAlias) (Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv); /* 86 */
- int (*tcl_CreateAliasObj) (Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]); /* 87 */
- Tcl_Channel (*tcl_CreateChannel) (Tcl_ChannelType *typePtr, CONST char *chanName, ClientData instanceData, int mask); /* 88 */
+ int (*tcl_CommandComplete) (const char *cmd); /* 82 */
+ char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */
+ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
+ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
+ int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
+ int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
+ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */
- Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
+ Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
- void (*tcl_CreateMathFunc) (Tcl_Interp *interp, CONST char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
- Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, CONST char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
- Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, CONST char *slaveName, int isSafe); /* 97 */
+ void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
+ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
+ Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */
- void (*tcl_DeleteAssocData) (Tcl_Interp *interp, CONST char *name); /* 100 */
+ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */
void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */
void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */
- int (*tcl_DeleteCommand) (Tcl_Interp *interp, CONST char *cmdName); /* 103 */
+ int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, ClientData clientData); /* 105 */
void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 106 */
@@ -3552,8 +1951,8 @@ typedef struct TclStubs {
void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */
int (*tcl_DoOneEvent) (int flags); /* 115 */
void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, ClientData clientData); /* 116 */
- char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, CONST char *bytes, int length); /* 117 */
- char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, CONST char *element); /* 118 */
+ char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */
+ char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */
void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */
void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */
void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */
@@ -3564,115 +1963,115 @@ typedef struct TclStubs {
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */
CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */
- int (*tcl_Eval) (Tcl_Interp *interp, CONST char *script); /* 129 */
- int (*tcl_EvalFile) (Tcl_Interp *interp, CONST char *fileName); /* 130 */
+ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
+ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
void (*tcl_Exit) (int status); /* 133 */
- int (*tcl_ExposeCommand) (Tcl_Interp *interp, CONST char *hiddenCmdToken, CONST char *cmdName); /* 134 */
- int (*tcl_ExprBoolean) (Tcl_Interp *interp, CONST char *expr, int *ptr); /* 135 */
+ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */
+ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */
int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */
- int (*tcl_ExprDouble) (Tcl_Interp *interp, CONST char *expr, double *ptr); /* 137 */
+ int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */
int (*tcl_ExprDoubleObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); /* 138 */
- int (*tcl_ExprLong) (Tcl_Interp *interp, CONST char *expr, long *ptr); /* 139 */
+ int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */
int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
- int (*tcl_ExprString) (Tcl_Interp *interp, CONST char *expr); /* 142 */
+ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
- void (*tcl_FindExecutable) (CONST char *argv0); /* 144 */
+ void (*tcl_FindExecutable) (const char *argv0); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
- int (*tcl_GetAlias) (Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
- ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
- Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, CONST char *chanName, int *modePtr); /* 151 */
+ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
+ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
+ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
+ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */
ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
- int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, Tcl_DString *dsPtr); /* 157 */
- Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
- int (*tcl_GetCommandInfo) (Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
+ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
+ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
+ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
- CONST char * (*tcl_GetNameOfExecutable) (void); /* 165 */
+ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- int (*tcl_GetOpenFile) (Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
+ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- VOID *reserved167;
+ void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- int (*tcl_GetOpenFile) (Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
+ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* MACOSX */
- Tcl_PathType (*tcl_GetPathType) (CONST char *path); /* 168 */
+ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
- Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, CONST char *slaveName); /* 172 */
+ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
- CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, CONST char *varName, int flags); /* 175 */
- CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags); /* 176 */
- int (*tcl_GlobalEval) (Tcl_Interp *interp, CONST char *command); /* 177 */
+ CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
+ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
- int (*tcl_HideCommand) (Tcl_Interp *interp, CONST char *cmdName, CONST char *hiddenCmdToken); /* 179 */
+ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
- char * (*tcl_JoinPath) (int argc, CONST84 char *CONST *argv, Tcl_DString *resultPtr); /* 186 */
- int (*tcl_LinkVar) (Tcl_Interp *interp, CONST char *varName, char *addr, int type); /* 187 */
- VOID *reserved188;
+ char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */
+ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */
+ void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */
- char * (*tcl_Merge) (int argc, CONST84 char *CONST *argv); /* 192 */
+ char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */
Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */
- Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, int permissions); /* 198 */
- Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, int myport, int async); /* 199 */
- Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, CONST char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
+ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
+ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
+ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
void (*tcl_Preserve) (ClientData data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
- int (*tcl_PutEnv) (CONST char *assignment); /* 203 */
+ int (*tcl_PutEnv) (const char *assignment); /* 203 */
CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
- int (*tcl_RecordAndEval) (Tcl_Interp *interp, CONST char *cmd, int flags); /* 208 */
+ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */
void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */
- void (*tcl_RegisterObjType) (Tcl_ObjType *typePtr); /* 211 */
- Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, CONST char *pattern); /* 212 */
- int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, CONST char *text, CONST char *start); /* 213 */
- int (*tcl_RegExpMatch) (Tcl_Interp *interp, CONST char *text, CONST char *pattern); /* 214 */
+ void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */
+ Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
+ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
+ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
void (*tcl_Release) (ClientData clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
- int (*tcl_ScanElement) (CONST char *str, int *flagPtr); /* 218 */
- int (*tcl_ScanCountedElement) (CONST char *str, int length, int *flagPtr); /* 219 */
+ int (*tcl_ScanElement) (const char *str, int *flagPtr); /* 218 */
+ int (*tcl_ScanCountedElement) (const char *str, int length, int *flagPtr); /* 219 */
int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
- void (*tcl_SetAssocData) (Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
+ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
- int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, CONST char *newValue); /* 225 */
- int (*tcl_SetCommandInfo) (Tcl_Interp *interp, CONST char *cmdName, CONST Tcl_CmdInfo *infoPtr); /* 226 */
+ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
+ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
- void (*tcl_SetMaxBlockTime) (Tcl_Time *timePtr); /* 229 */
+ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
void (*tcl_SetPanicProc) (Tcl_PanicProc *panicProc); /* 230 */
int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */
@@ -3680,112 +2079,112 @@ typedef struct TclStubs {
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
- CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, CONST char *varName, CONST char *newValue, int flags); /* 237 */
- CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, CONST char *newValue, int flags); /* 238 */
+ CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */
CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
- int (*tcl_SplitList) (Tcl_Interp *interp, CONST char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
- void (*tcl_SplitPath) (CONST char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
- void (*tcl_StaticPackage) (Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
- int (*tcl_StringMatch) (CONST char *str, CONST char *pattern); /* 245 */
+ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
+ void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
+ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
+ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
- int (*tcl_TraceVar) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
- int (*tcl_TraceVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
- char * (*tcl_TranslateFileName) (Tcl_Interp *interp, CONST char *name, Tcl_DString *bufferPtr); /* 249 */
- int (*tcl_Ungets) (Tcl_Channel chan, CONST char *str, int len, int atHead); /* 250 */
- void (*tcl_UnlinkVar) (Tcl_Interp *interp, CONST char *varName); /* 251 */
+ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
+ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
+ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
+ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
+ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
- int (*tcl_UnsetVar) (Tcl_Interp *interp, CONST char *varName, int flags); /* 253 */
- int (*tcl_UnsetVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags); /* 254 */
- void (*tcl_UntraceVar) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
- void (*tcl_UntraceVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
- void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, CONST char *varName); /* 257 */
- int (*tcl_UpVar) (Tcl_Interp *interp, CONST char *frameName, CONST char *varName, CONST char *localName, int flags); /* 258 */
- int (*tcl_UpVar2) (Tcl_Interp *interp, CONST char *frameName, CONST char *part1, CONST char *part2, CONST char *localName, int flags); /* 259 */
+ int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
+ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
+ void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
+ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
+ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */
+ int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
+ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */
int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */
- ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
- ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
- int (*tcl_Write) (Tcl_Channel chan, CONST char *s, int slen); /* 263 */
- void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *message); /* 264 */
- int (*tcl_DumpActiveMemory) (CONST char *fileName); /* 265 */
- void (*tcl_ValidateAllMemory) (CONST char *file, int line); /* 266 */
+ ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
+ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
+ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
+ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
+ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */
+ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */
void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
- CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, CONST char *start, CONST84 char **termPtr); /* 270 */
- CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact); /* 271 */
- CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr); /* 272 */
- int (*tcl_PkgProvide) (Tcl_Interp *interp, CONST char *name, CONST char *version); /* 273 */
- CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact); /* 274 */
+ CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */
+ CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
+ int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
+ CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
- void (*tcl_PanicVA) (CONST char *format, va_list argList); /* 278 */
+ void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
- Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
+ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
- VOID *reserved285;
+ void (*reserved285)(void);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
- Tcl_Encoding (*tcl_CreateEncoding) (CONST Tcl_EncodingType *typePtr); /* 287 */
+ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */
void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
- int (*tcl_EvalEx) (Tcl_Interp *interp, CONST char *script, int numBytes, int flags); /* 291 */
- int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 292 */
+ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
+ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
void (*tcl_ExitThread) (int status); /* 294 */
- int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
- char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
+ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
+ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
- Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, CONST char *name); /* 301 */
+ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
- int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST VOID *tablePtr, int offset, CONST char *msg, int flags, int *indexPtr); /* 304 */
- VOID * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
- Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags); /* 306 */
+ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */
+ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
+ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */
ClientData (*tcl_InitNotifier) (void); /* 307 */
void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */
void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */
void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */
- void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr); /* 311 */
- int (*tcl_NumUtfChars) (CONST char *src, int length); /* 312 */
+ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */
+ int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */
int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */
void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
- int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, CONST char *name); /* 316 */
- Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
+ int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
+ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
- Tcl_UniChar (*tcl_UniCharAtIndex) (CONST char *src, int index); /* 320 */
+ Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */
Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
- CONST84_RETURN char * (*tcl_UtfAtIndex) (CONST char *src, int index); /* 325 */
- int (*tcl_UtfCharComplete) (CONST char *src, int length); /* 326 */
- int (*tcl_UtfBackslash) (CONST char *src, int *readPtr, char *dst); /* 327 */
- CONST84_RETURN char * (*tcl_UtfFindFirst) (CONST char *src, int ch); /* 328 */
- CONST84_RETURN char * (*tcl_UtfFindLast) (CONST char *src, int ch); /* 329 */
- CONST84_RETURN char * (*tcl_UtfNext) (CONST char *src); /* 330 */
- CONST84_RETURN char * (*tcl_UtfPrev) (CONST char *src, CONST char *start); /* 331 */
- int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
- char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
+ CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
+ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
+ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
+ CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */
+ CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
+ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
+ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
int (*tcl_UtfToTitle) (char *src); /* 335 */
- int (*tcl_UtfToUniChar) (CONST char *src, Tcl_UniChar *chPtr); /* 336 */
+ int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 336 */
int (*tcl_UtfToUpper) (char *src); /* 337 */
- int (*tcl_WriteChars) (Tcl_Channel chan, CONST char *src, int srcLen); /* 338 */
+ int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
- void (*tcl_SetDefaultEncodingDir) (CONST char *path); /* 342 */
+ void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
@@ -3795,91 +2194,91 @@ typedef struct TclStubs {
int (*tcl_UniCharIsSpace) (int ch); /* 349 */
int (*tcl_UniCharIsUpper) (int ch); /* 350 */
int (*tcl_UniCharIsWordChar) (int ch); /* 351 */
- int (*tcl_UniCharLen) (CONST Tcl_UniChar *uniStr); /* 352 */
- int (*tcl_UniCharNcmp) (CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars); /* 353 */
- char * (*tcl_UniCharToUtfDString) (CONST Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
- Tcl_UniChar * (*tcl_UtfToUniCharDString) (CONST char *src, int length, Tcl_DString *dsPtr); /* 355 */
+ int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
+ int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */
+ char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
+ Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
- void (*tcl_LogCommandInfo) (Tcl_Interp *interp, CONST char *script, CONST char *command, int length); /* 359 */
- int (*tcl_ParseBraces) (Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */
- int (*tcl_ParseCommand) (Tcl_Interp *interp, CONST char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
- int (*tcl_ParseExpr) (Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
- int (*tcl_ParseQuotedString) (Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */
- int (*tcl_ParseVarName) (Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
+ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */
+ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */
+ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
+ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
+ int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */
+ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
- int (*tcl_Chdir) (CONST char *dirName); /* 366 */
- int (*tcl_Access) (CONST char *path, int mode); /* 367 */
- int (*tcl_Stat) (CONST char *path, struct stat *bufPtr); /* 368 */
- int (*tcl_UtfNcmp) (CONST char *s1, CONST char *s2, unsigned long n); /* 369 */
- int (*tcl_UtfNcasecmp) (CONST char *s1, CONST char *s2, unsigned long n); /* 370 */
- int (*tcl_StringCaseMatch) (CONST char *str, CONST char *pattern, int nocase); /* 371 */
+ int (*tcl_Chdir) (const char *dirName); /* 366 */
+ int (*tcl_Access) (const char *path, int mode); /* 367 */
+ int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */
+ int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */
+ int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */
+ int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */
int (*tcl_UniCharIsControl) (int ch); /* 372 */
int (*tcl_UniCharIsGraph) (int ch); /* 373 */
int (*tcl_UniCharIsPrint) (int ch); /* 374 */
int (*tcl_UniCharIsPunct) (int ch); /* 375 */
int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */
void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */
- Tcl_Obj * (*tcl_NewUnicodeObj) (CONST Tcl_UniChar *unicode, int numChars); /* 378 */
- void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars); /* 379 */
+ Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
+ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
- void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int length); /* 384 */
+ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */
- int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, CONST char *pattern); /* 389 */
- int (*tcl_ProcObjCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 390 */
+ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */
+ int (*tcl_ProcObjCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */
void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */
void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */
- int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags); /* 393 */
+ int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); /* 393 */
int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
- int (*tcl_WriteRaw) (Tcl_Channel chan, CONST char *src, int srcLen); /* 395 */
+ int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
- CONST84_RETURN char * (*tcl_ChannelName) (CONST Tcl_ChannelType *chanTypePtr); /* 398 */
- Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (CONST Tcl_ChannelType *chanTypePtr); /* 399 */
- Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (CONST Tcl_ChannelType *chanTypePtr); /* 400 */
- Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (CONST Tcl_ChannelType *chanTypePtr); /* 401 */
- Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (CONST Tcl_ChannelType *chanTypePtr); /* 402 */
- Tcl_DriverInputProc * (*tcl_ChannelInputProc) (CONST Tcl_ChannelType *chanTypePtr); /* 403 */
- Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (CONST Tcl_ChannelType *chanTypePtr); /* 404 */
- Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (CONST Tcl_ChannelType *chanTypePtr); /* 405 */
- Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (CONST Tcl_ChannelType *chanTypePtr); /* 406 */
- Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (CONST Tcl_ChannelType *chanTypePtr); /* 407 */
- Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (CONST Tcl_ChannelType *chanTypePtr); /* 408 */
- Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) (CONST Tcl_ChannelType *chanTypePtr); /* 409 */
- Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) (CONST Tcl_ChannelType *chanTypePtr); /* 410 */
- Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) (CONST Tcl_ChannelType *chanTypePtr); /* 411 */
+ CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
+ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
+ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
+ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
+ Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */
+ Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */
+ Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */
+ Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */
+ Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */
+ Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */
+ Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */
+ Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) (const Tcl_ChannelType *chanTypePtr); /* 409 */
+ Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) (const Tcl_ChannelType *chanTypePtr); /* 410 */
+ Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) (const Tcl_ChannelType *chanTypePtr); /* 411 */
int (*tcl_JoinThread) (Tcl_ThreadId threadId, int *result); /* 412 */
int (*tcl_IsChannelShared) (Tcl_Channel channel); /* 413 */
int (*tcl_IsChannelRegistered) (Tcl_Interp *interp, Tcl_Channel channel); /* 414 */
void (*tcl_CutChannel) (Tcl_Channel channel); /* 415 */
void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */
void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */
- int (*tcl_IsChannelExisting) (CONST char *channelName); /* 418 */
- int (*tcl_UniCharNcasecmp) (CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars); /* 419 */
- int (*tcl_UniCharCaseMatch) (CONST Tcl_UniChar *uniStr, CONST Tcl_UniChar *uniPattern, int nocase); /* 420 */
- Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, CONST char *key); /* 421 */
- Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, CONST char *key, int *newPtr); /* 422 */
- void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, Tcl_HashKeyType *typePtr); /* 423 */
+ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */
+ int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */
+ int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */
+ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */
+ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */
+ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */
void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */
- ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */
- int (*tcl_TraceCommand) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */
- void (*tcl_UntraceCommand) (Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */
+ ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */
+ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */
+ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */
char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */
- char * (*tcl_AttemptDbCkalloc) (unsigned int size, CONST char *file, int line); /* 429 */
+ char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */
char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */
- char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, CONST char *file, int line); /* 431 */
+ char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
- int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, CONST char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
- Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, CONST char *pattern); /* 436 */
+ int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
+ Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */
@@ -3887,8 +2286,8 @@ typedef struct TclStubs {
int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */
int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */
int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */
- int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *sym1, CONST char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */
- int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types); /* 445 */
+ int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */
+ int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); /* 445 */
Tcl_Obj * (*tcl_FSLink) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); /* 446 */
int (*tcl_FSRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 447 */
int (*tcl_FSRenameFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 448 */
@@ -3896,10 +2295,10 @@ typedef struct TclStubs {
int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */
int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */
int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */
- CONST char ** (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */
+ const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */
int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */
int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */
- Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *modeString, int permissions); /* 456 */
+ Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */
Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */
int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */
int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */
@@ -3907,36 +2306,36 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */
int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */
Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */
- Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *CONST objv[]); /* 464 */
- ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, Tcl_Filesystem *fsPtr); /* 465 */
+ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 464 */
+ ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */
Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */
int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */
- Tcl_Obj * (*tcl_FSNewNativePath) (Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */
- CONST char * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */
+ Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */
+ const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */
Tcl_Obj * (*tcl_FSFileSystemInfo) (Tcl_Obj *pathPtr); /* 470 */
Tcl_Obj * (*tcl_FSPathSeparator) (Tcl_Obj *pathPtr); /* 471 */
Tcl_Obj * (*tcl_FSListVolumes) (void); /* 472 */
- int (*tcl_FSRegister) (ClientData clientData, Tcl_Filesystem *fsPtr); /* 473 */
- int (*tcl_FSUnregister) (Tcl_Filesystem *fsPtr); /* 474 */
- ClientData (*tcl_FSData) (Tcl_Filesystem *fsPtr); /* 475 */
- CONST char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */
- Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */
+ int (*tcl_FSRegister) (ClientData clientData, const Tcl_Filesystem *fsPtr); /* 473 */
+ int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */
+ ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */
+ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */
+ CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */
Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */
int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */
- void (*tcl_FSMountsChanged) (Tcl_Filesystem *fsPtr); /* 480 */
+ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */
int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */
void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */
Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */
int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */
- int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, CONST Tcl_CmdInfo *infoPtr); /* 485 */
- Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, CONST char *file, int line); /* 486 */
+ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */
+ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */
int (*tcl_GetWideIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */
void (*tcl_SetWideIntObj) (Tcl_Obj *objPtr, Tcl_WideInt wideValue); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
Tcl_WideInt (*tcl_Seek) (Tcl_Channel chan, Tcl_WideInt offset, int mode); /* 491 */
Tcl_WideInt (*tcl_Tell) (Tcl_Channel chan); /* 492 */
- Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (CONST Tcl_ChannelType *chanTypePtr); /* 493 */
+ Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 493 */
int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */
int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */
int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */
@@ -3944,24 +2343,24 @@ typedef struct TclStubs {
int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
- int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *CONST *keyv, Tcl_Obj *valuePtr); /* 501 */
- int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *CONST *keyv); /* 502 */
+ int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
+ int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
- Tcl_Obj * (*tcl_DbNewDictObj) (CONST char *file, int line); /* 504 */
- void (*tcl_RegisterConfig) (Tcl_Interp *interp, CONST char *pkgName, Tcl_Config *configuration, CONST char *valEncoding); /* 505 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
+ Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
+ void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
+ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */
int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int resetListFirst); /* 509 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int allowOverwrite); /* 510 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern); /* 511 */
+ int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */
+ int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 510 */
+ int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 511 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 512 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 513 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */
+ Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */
+ Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */
Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */
void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */
- int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, CONST char *encodingName); /* 518 */
+ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
Tcl_ExitProc * (*tcl_SetExitProc) (Tcl_ExitProc *proc); /* 519 */
void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */
@@ -3984,7 +2383,7 @@ typedef struct TclStubs {
int (*tcl_SetReturnOptions) (Tcl_Interp *interp, Tcl_Obj *options); /* 538 */
Tcl_Obj * (*tcl_GetReturnOptions) (Tcl_Interp *interp, int result); /* 539 */
int (*tcl_IsEnsemble) (Tcl_Command token); /* 540 */
- Tcl_Command (*tcl_CreateEnsemble) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *namespacePtr, int flags); /* 541 */
+ Tcl_Command (*tcl_CreateEnsemble) (Tcl_Interp *interp, const char *name, Tcl_Namespace *namespacePtr, int flags); /* 541 */
Tcl_Command (*tcl_FindEnsemble) (Tcl_Interp *interp, Tcl_Obj *cmdNameObj, int flags); /* 542 */
int (*tcl_SetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *subcmdList); /* 543 */
int (*tcl_SetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *mapDict); /* 544 */
@@ -3997,14 +2396,14 @@ typedef struct TclStubs {
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */
void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */
- Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (CONST Tcl_ChannelType *chanTypePtr); /* 554 */
+ Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */
Tcl_Obj * (*tcl_NewBignumObj) (mp_int *value); /* 555 */
- Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, CONST char *file, int line); /* 556 */
+ Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, const char *file, int line); /* 556 */
void (*tcl_SetBignumObj) (Tcl_Obj *obj, mp_int *value); /* 557 */
int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 558 */
int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 559 */
int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */
- Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (CONST Tcl_ChannelType *chanTypePtr); /* 561 */
+ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */
void (*tcl_SetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj *msg); /* 562 */
void (*tcl_GetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj **msg); /* 563 */
void (*tcl_SetChannelError) (Tcl_Channel chan, Tcl_Obj *msg); /* 564 */
@@ -4015,2375 +2414,1388 @@ typedef struct TclStubs {
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
- CONST char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
- int (*tcl_PkgRequireProc) (Tcl_Interp *interp, CONST char *name, int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr); /* 573 */
+ const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
+ int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */
- void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, CONST char *bytes, int length, int limit, CONST char *ellipsis); /* 575 */
- Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, CONST char *format, int objc, Tcl_Obj *CONST objv[]); /* 576 */
- int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, int objc, Tcl_Obj *CONST objv[]); /* 577 */
- Tcl_Obj * (*tcl_ObjPrintf) (CONST char *format, ...); /* 578 */
- void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, CONST char *format, ...); /* 579 */
+ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */
+ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */
+ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */
+ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */
+ void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */
+ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */
+ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */
+ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */
+ Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */
+ int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */
+ int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */
+ int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */
+ void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */
+ int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 588 */
+ unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */
+ unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */
+ unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */
+ int (*tcl_GetLinkCountFromStat) (const Tcl_StatBuf *statPtr); /* 592 */
+ int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */
+ int (*tcl_GetGroupIdFromStat) (const Tcl_StatBuf *statPtr); /* 594 */
+ int (*tcl_GetDeviceTypeFromStat) (const Tcl_StatBuf *statPtr); /* 595 */
+ Tcl_WideInt (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */
+ Tcl_WideInt (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */
+ Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */
+ Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */
+ Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */
+ unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */
+ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */
+ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */
+ int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */
+ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */
+ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */
+ void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); /* 607 */
+ int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */
+ void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */
+ int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */
+ int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
+ unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, int len); /* 612 */
+ unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, int len); /* 613 */
+ int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */
+ Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */
+ int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */
+ int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */
+ int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */
+ int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 619 */
+ int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */
+ int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */
+ void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */
+ Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */
+ int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */
+ int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */
+ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */
+ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */
+ void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
+ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
-extern TclStubs *tclStubsPtr;
+extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
-#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
-#ifndef Tcl_PkgProvideEx
#define Tcl_PkgProvideEx \
(tclStubsPtr->tcl_PkgProvideEx) /* 0 */
-#endif
-#ifndef Tcl_PkgRequireEx
#define Tcl_PkgRequireEx \
(tclStubsPtr->tcl_PkgRequireEx) /* 1 */
-#endif
-#ifndef Tcl_Panic
#define Tcl_Panic \
(tclStubsPtr->tcl_Panic) /* 2 */
-#endif
-#ifndef Tcl_Alloc
#define Tcl_Alloc \
(tclStubsPtr->tcl_Alloc) /* 3 */
-#endif
-#ifndef Tcl_Free
#define Tcl_Free \
(tclStubsPtr->tcl_Free) /* 4 */
-#endif
-#ifndef Tcl_Realloc
#define Tcl_Realloc \
(tclStubsPtr->tcl_Realloc) /* 5 */
-#endif
-#ifndef Tcl_DbCkalloc
#define Tcl_DbCkalloc \
(tclStubsPtr->tcl_DbCkalloc) /* 6 */
-#endif
-#ifndef Tcl_DbCkfree
#define Tcl_DbCkfree \
(tclStubsPtr->tcl_DbCkfree) /* 7 */
-#endif
-#ifndef Tcl_DbCkrealloc
#define Tcl_DbCkrealloc \
(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
-#endif
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
-#endif
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
-#endif
#endif /* MACOSX */
-#ifndef Tcl_SetTimer
#define Tcl_SetTimer \
(tclStubsPtr->tcl_SetTimer) /* 11 */
-#endif
-#ifndef Tcl_Sleep
#define Tcl_Sleep \
(tclStubsPtr->tcl_Sleep) /* 12 */
-#endif
-#ifndef Tcl_WaitForEvent
#define Tcl_WaitForEvent \
(tclStubsPtr->tcl_WaitForEvent) /* 13 */
-#endif
-#ifndef Tcl_AppendAllObjTypes
#define Tcl_AppendAllObjTypes \
(tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */
-#endif
-#ifndef Tcl_AppendStringsToObj
#define Tcl_AppendStringsToObj \
(tclStubsPtr->tcl_AppendStringsToObj) /* 15 */
-#endif
-#ifndef Tcl_AppendToObj
#define Tcl_AppendToObj \
(tclStubsPtr->tcl_AppendToObj) /* 16 */
-#endif
-#ifndef Tcl_ConcatObj
#define Tcl_ConcatObj \
(tclStubsPtr->tcl_ConcatObj) /* 17 */
-#endif
-#ifndef Tcl_ConvertToType
#define Tcl_ConvertToType \
(tclStubsPtr->tcl_ConvertToType) /* 18 */
-#endif
-#ifndef Tcl_DbDecrRefCount
#define Tcl_DbDecrRefCount \
(tclStubsPtr->tcl_DbDecrRefCount) /* 19 */
-#endif
-#ifndef Tcl_DbIncrRefCount
#define Tcl_DbIncrRefCount \
(tclStubsPtr->tcl_DbIncrRefCount) /* 20 */
-#endif
-#ifndef Tcl_DbIsShared
#define Tcl_DbIsShared \
(tclStubsPtr->tcl_DbIsShared) /* 21 */
-#endif
-#ifndef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj \
(tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */
-#endif
-#ifndef Tcl_DbNewByteArrayObj
#define Tcl_DbNewByteArrayObj \
(tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */
-#endif
-#ifndef Tcl_DbNewDoubleObj
#define Tcl_DbNewDoubleObj \
(tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */
-#endif
-#ifndef Tcl_DbNewListObj
#define Tcl_DbNewListObj \
(tclStubsPtr->tcl_DbNewListObj) /* 25 */
-#endif
-#ifndef Tcl_DbNewLongObj
#define Tcl_DbNewLongObj \
(tclStubsPtr->tcl_DbNewLongObj) /* 26 */
-#endif
-#ifndef Tcl_DbNewObj
#define Tcl_DbNewObj \
(tclStubsPtr->tcl_DbNewObj) /* 27 */
-#endif
-#ifndef Tcl_DbNewStringObj
#define Tcl_DbNewStringObj \
(tclStubsPtr->tcl_DbNewStringObj) /* 28 */
-#endif
-#ifndef Tcl_DuplicateObj
#define Tcl_DuplicateObj \
(tclStubsPtr->tcl_DuplicateObj) /* 29 */
-#endif
-#ifndef TclFreeObj
#define TclFreeObj \
(tclStubsPtr->tclFreeObj) /* 30 */
-#endif
-#ifndef Tcl_GetBoolean
#define Tcl_GetBoolean \
(tclStubsPtr->tcl_GetBoolean) /* 31 */
-#endif
-#ifndef Tcl_GetBooleanFromObj
#define Tcl_GetBooleanFromObj \
(tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */
-#endif
-#ifndef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj \
(tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */
-#endif
-#ifndef Tcl_GetDouble
#define Tcl_GetDouble \
(tclStubsPtr->tcl_GetDouble) /* 34 */
-#endif
-#ifndef Tcl_GetDoubleFromObj
#define Tcl_GetDoubleFromObj \
(tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */
-#endif
-#ifndef Tcl_GetIndexFromObj
#define Tcl_GetIndexFromObj \
(tclStubsPtr->tcl_GetIndexFromObj) /* 36 */
-#endif
-#ifndef Tcl_GetInt
#define Tcl_GetInt \
(tclStubsPtr->tcl_GetInt) /* 37 */
-#endif
-#ifndef Tcl_GetIntFromObj
#define Tcl_GetIntFromObj \
(tclStubsPtr->tcl_GetIntFromObj) /* 38 */
-#endif
-#ifndef Tcl_GetLongFromObj
#define Tcl_GetLongFromObj \
(tclStubsPtr->tcl_GetLongFromObj) /* 39 */
-#endif
-#ifndef Tcl_GetObjType
#define Tcl_GetObjType \
(tclStubsPtr->tcl_GetObjType) /* 40 */
-#endif
-#ifndef Tcl_GetStringFromObj
#define Tcl_GetStringFromObj \
(tclStubsPtr->tcl_GetStringFromObj) /* 41 */
-#endif
-#ifndef Tcl_InvalidateStringRep
#define Tcl_InvalidateStringRep \
(tclStubsPtr->tcl_InvalidateStringRep) /* 42 */
-#endif
-#ifndef Tcl_ListObjAppendList
#define Tcl_ListObjAppendList \
(tclStubsPtr->tcl_ListObjAppendList) /* 43 */
-#endif
-#ifndef Tcl_ListObjAppendElement
#define Tcl_ListObjAppendElement \
(tclStubsPtr->tcl_ListObjAppendElement) /* 44 */
-#endif
-#ifndef Tcl_ListObjGetElements
#define Tcl_ListObjGetElements \
(tclStubsPtr->tcl_ListObjGetElements) /* 45 */
-#endif
-#ifndef Tcl_ListObjIndex
#define Tcl_ListObjIndex \
(tclStubsPtr->tcl_ListObjIndex) /* 46 */
-#endif
-#ifndef Tcl_ListObjLength
#define Tcl_ListObjLength \
(tclStubsPtr->tcl_ListObjLength) /* 47 */
-#endif
-#ifndef Tcl_ListObjReplace
#define Tcl_ListObjReplace \
(tclStubsPtr->tcl_ListObjReplace) /* 48 */
-#endif
-#ifndef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj \
(tclStubsPtr->tcl_NewBooleanObj) /* 49 */
-#endif
-#ifndef Tcl_NewByteArrayObj
#define Tcl_NewByteArrayObj \
(tclStubsPtr->tcl_NewByteArrayObj) /* 50 */
-#endif
-#ifndef Tcl_NewDoubleObj
#define Tcl_NewDoubleObj \
(tclStubsPtr->tcl_NewDoubleObj) /* 51 */
-#endif
-#ifndef Tcl_NewIntObj
#define Tcl_NewIntObj \
(tclStubsPtr->tcl_NewIntObj) /* 52 */
-#endif
-#ifndef Tcl_NewListObj
#define Tcl_NewListObj \
(tclStubsPtr->tcl_NewListObj) /* 53 */
-#endif
-#ifndef Tcl_NewLongObj
#define Tcl_NewLongObj \
(tclStubsPtr->tcl_NewLongObj) /* 54 */
-#endif
-#ifndef Tcl_NewObj
#define Tcl_NewObj \
(tclStubsPtr->tcl_NewObj) /* 55 */
-#endif
-#ifndef Tcl_NewStringObj
#define Tcl_NewStringObj \
(tclStubsPtr->tcl_NewStringObj) /* 56 */
-#endif
-#ifndef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj \
(tclStubsPtr->tcl_SetBooleanObj) /* 57 */
-#endif
-#ifndef Tcl_SetByteArrayLength
#define Tcl_SetByteArrayLength \
(tclStubsPtr->tcl_SetByteArrayLength) /* 58 */
-#endif
-#ifndef Tcl_SetByteArrayObj
#define Tcl_SetByteArrayObj \
(tclStubsPtr->tcl_SetByteArrayObj) /* 59 */
-#endif
-#ifndef Tcl_SetDoubleObj
#define Tcl_SetDoubleObj \
(tclStubsPtr->tcl_SetDoubleObj) /* 60 */
-#endif
-#ifndef Tcl_SetIntObj
#define Tcl_SetIntObj \
(tclStubsPtr->tcl_SetIntObj) /* 61 */
-#endif
-#ifndef Tcl_SetListObj
#define Tcl_SetListObj \
(tclStubsPtr->tcl_SetListObj) /* 62 */
-#endif
-#ifndef Tcl_SetLongObj
#define Tcl_SetLongObj \
(tclStubsPtr->tcl_SetLongObj) /* 63 */
-#endif
-#ifndef Tcl_SetObjLength
#define Tcl_SetObjLength \
(tclStubsPtr->tcl_SetObjLength) /* 64 */
-#endif
-#ifndef Tcl_SetStringObj
#define Tcl_SetStringObj \
(tclStubsPtr->tcl_SetStringObj) /* 65 */
-#endif
-#ifndef Tcl_AddErrorInfo
#define Tcl_AddErrorInfo \
(tclStubsPtr->tcl_AddErrorInfo) /* 66 */
-#endif
-#ifndef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo \
(tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */
-#endif
-#ifndef Tcl_AllowExceptions
#define Tcl_AllowExceptions \
(tclStubsPtr->tcl_AllowExceptions) /* 68 */
-#endif
-#ifndef Tcl_AppendElement
#define Tcl_AppendElement \
(tclStubsPtr->tcl_AppendElement) /* 69 */
-#endif
-#ifndef Tcl_AppendResult
#define Tcl_AppendResult \
(tclStubsPtr->tcl_AppendResult) /* 70 */
-#endif
-#ifndef Tcl_AsyncCreate
#define Tcl_AsyncCreate \
(tclStubsPtr->tcl_AsyncCreate) /* 71 */
-#endif
-#ifndef Tcl_AsyncDelete
#define Tcl_AsyncDelete \
(tclStubsPtr->tcl_AsyncDelete) /* 72 */
-#endif
-#ifndef Tcl_AsyncInvoke
#define Tcl_AsyncInvoke \
(tclStubsPtr->tcl_AsyncInvoke) /* 73 */
-#endif
-#ifndef Tcl_AsyncMark
#define Tcl_AsyncMark \
(tclStubsPtr->tcl_AsyncMark) /* 74 */
-#endif
-#ifndef Tcl_AsyncReady
#define Tcl_AsyncReady \
(tclStubsPtr->tcl_AsyncReady) /* 75 */
-#endif
-#ifndef Tcl_BackgroundError
#define Tcl_BackgroundError \
(tclStubsPtr->tcl_BackgroundError) /* 76 */
-#endif
-#ifndef Tcl_Backslash
#define Tcl_Backslash \
(tclStubsPtr->tcl_Backslash) /* 77 */
-#endif
-#ifndef Tcl_BadChannelOption
#define Tcl_BadChannelOption \
(tclStubsPtr->tcl_BadChannelOption) /* 78 */
-#endif
-#ifndef Tcl_CallWhenDeleted
#define Tcl_CallWhenDeleted \
(tclStubsPtr->tcl_CallWhenDeleted) /* 79 */
-#endif
-#ifndef Tcl_CancelIdleCall
#define Tcl_CancelIdleCall \
(tclStubsPtr->tcl_CancelIdleCall) /* 80 */
-#endif
-#ifndef Tcl_Close
#define Tcl_Close \
(tclStubsPtr->tcl_Close) /* 81 */
-#endif
-#ifndef Tcl_CommandComplete
#define Tcl_CommandComplete \
(tclStubsPtr->tcl_CommandComplete) /* 82 */
-#endif
-#ifndef Tcl_Concat
#define Tcl_Concat \
(tclStubsPtr->tcl_Concat) /* 83 */
-#endif
-#ifndef Tcl_ConvertElement
#define Tcl_ConvertElement \
(tclStubsPtr->tcl_ConvertElement) /* 84 */
-#endif
-#ifndef Tcl_ConvertCountedElement
#define Tcl_ConvertCountedElement \
(tclStubsPtr->tcl_ConvertCountedElement) /* 85 */
-#endif
-#ifndef Tcl_CreateAlias
#define Tcl_CreateAlias \
(tclStubsPtr->tcl_CreateAlias) /* 86 */
-#endif
-#ifndef Tcl_CreateAliasObj
#define Tcl_CreateAliasObj \
(tclStubsPtr->tcl_CreateAliasObj) /* 87 */
-#endif
-#ifndef Tcl_CreateChannel
#define Tcl_CreateChannel \
(tclStubsPtr->tcl_CreateChannel) /* 88 */
-#endif
-#ifndef Tcl_CreateChannelHandler
#define Tcl_CreateChannelHandler \
(tclStubsPtr->tcl_CreateChannelHandler) /* 89 */
-#endif
-#ifndef Tcl_CreateCloseHandler
#define Tcl_CreateCloseHandler \
(tclStubsPtr->tcl_CreateCloseHandler) /* 90 */
-#endif
-#ifndef Tcl_CreateCommand
#define Tcl_CreateCommand \
(tclStubsPtr->tcl_CreateCommand) /* 91 */
-#endif
-#ifndef Tcl_CreateEventSource
#define Tcl_CreateEventSource \
(tclStubsPtr->tcl_CreateEventSource) /* 92 */
-#endif
-#ifndef Tcl_CreateExitHandler
#define Tcl_CreateExitHandler \
(tclStubsPtr->tcl_CreateExitHandler) /* 93 */
-#endif
-#ifndef Tcl_CreateInterp
#define Tcl_CreateInterp \
(tclStubsPtr->tcl_CreateInterp) /* 94 */
-#endif
-#ifndef Tcl_CreateMathFunc
#define Tcl_CreateMathFunc \
(tclStubsPtr->tcl_CreateMathFunc) /* 95 */
-#endif
-#ifndef Tcl_CreateObjCommand
#define Tcl_CreateObjCommand \
(tclStubsPtr->tcl_CreateObjCommand) /* 96 */
-#endif
-#ifndef Tcl_CreateSlave
#define Tcl_CreateSlave \
(tclStubsPtr->tcl_CreateSlave) /* 97 */
-#endif
-#ifndef Tcl_CreateTimerHandler
#define Tcl_CreateTimerHandler \
(tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
-#endif
-#ifndef Tcl_CreateTrace
#define Tcl_CreateTrace \
(tclStubsPtr->tcl_CreateTrace) /* 99 */
-#endif
-#ifndef Tcl_DeleteAssocData
#define Tcl_DeleteAssocData \
(tclStubsPtr->tcl_DeleteAssocData) /* 100 */
-#endif
-#ifndef Tcl_DeleteChannelHandler
#define Tcl_DeleteChannelHandler \
(tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */
-#endif
-#ifndef Tcl_DeleteCloseHandler
#define Tcl_DeleteCloseHandler \
(tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */
-#endif
-#ifndef Tcl_DeleteCommand
#define Tcl_DeleteCommand \
(tclStubsPtr->tcl_DeleteCommand) /* 103 */
-#endif
-#ifndef Tcl_DeleteCommandFromToken
#define Tcl_DeleteCommandFromToken \
(tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */
-#endif
-#ifndef Tcl_DeleteEvents
#define Tcl_DeleteEvents \
(tclStubsPtr->tcl_DeleteEvents) /* 105 */
-#endif
-#ifndef Tcl_DeleteEventSource
#define Tcl_DeleteEventSource \
(tclStubsPtr->tcl_DeleteEventSource) /* 106 */
-#endif
-#ifndef Tcl_DeleteExitHandler
#define Tcl_DeleteExitHandler \
(tclStubsPtr->tcl_DeleteExitHandler) /* 107 */
-#endif
-#ifndef Tcl_DeleteHashEntry
#define Tcl_DeleteHashEntry \
(tclStubsPtr->tcl_DeleteHashEntry) /* 108 */
-#endif
-#ifndef Tcl_DeleteHashTable
#define Tcl_DeleteHashTable \
(tclStubsPtr->tcl_DeleteHashTable) /* 109 */
-#endif
-#ifndef Tcl_DeleteInterp
#define Tcl_DeleteInterp \
(tclStubsPtr->tcl_DeleteInterp) /* 110 */
-#endif
-#ifndef Tcl_DetachPids
#define Tcl_DetachPids \
(tclStubsPtr->tcl_DetachPids) /* 111 */
-#endif
-#ifndef Tcl_DeleteTimerHandler
#define Tcl_DeleteTimerHandler \
(tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */
-#endif
-#ifndef Tcl_DeleteTrace
#define Tcl_DeleteTrace \
(tclStubsPtr->tcl_DeleteTrace) /* 113 */
-#endif
-#ifndef Tcl_DontCallWhenDeleted
#define Tcl_DontCallWhenDeleted \
(tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */
-#endif
-#ifndef Tcl_DoOneEvent
#define Tcl_DoOneEvent \
(tclStubsPtr->tcl_DoOneEvent) /* 115 */
-#endif
-#ifndef Tcl_DoWhenIdle
#define Tcl_DoWhenIdle \
(tclStubsPtr->tcl_DoWhenIdle) /* 116 */
-#endif
-#ifndef Tcl_DStringAppend
#define Tcl_DStringAppend \
(tclStubsPtr->tcl_DStringAppend) /* 117 */
-#endif
-#ifndef Tcl_DStringAppendElement
#define Tcl_DStringAppendElement \
(tclStubsPtr->tcl_DStringAppendElement) /* 118 */
-#endif
-#ifndef Tcl_DStringEndSublist
#define Tcl_DStringEndSublist \
(tclStubsPtr->tcl_DStringEndSublist) /* 119 */
-#endif
-#ifndef Tcl_DStringFree
#define Tcl_DStringFree \
(tclStubsPtr->tcl_DStringFree) /* 120 */
-#endif
-#ifndef Tcl_DStringGetResult
#define Tcl_DStringGetResult \
(tclStubsPtr->tcl_DStringGetResult) /* 121 */
-#endif
-#ifndef Tcl_DStringInit
#define Tcl_DStringInit \
(tclStubsPtr->tcl_DStringInit) /* 122 */
-#endif
-#ifndef Tcl_DStringResult
#define Tcl_DStringResult \
(tclStubsPtr->tcl_DStringResult) /* 123 */
-#endif
-#ifndef Tcl_DStringSetLength
#define Tcl_DStringSetLength \
(tclStubsPtr->tcl_DStringSetLength) /* 124 */
-#endif
-#ifndef Tcl_DStringStartSublist
#define Tcl_DStringStartSublist \
(tclStubsPtr->tcl_DStringStartSublist) /* 125 */
-#endif
-#ifndef Tcl_Eof
#define Tcl_Eof \
(tclStubsPtr->tcl_Eof) /* 126 */
-#endif
-#ifndef Tcl_ErrnoId
#define Tcl_ErrnoId \
(tclStubsPtr->tcl_ErrnoId) /* 127 */
-#endif
-#ifndef Tcl_ErrnoMsg
#define Tcl_ErrnoMsg \
(tclStubsPtr->tcl_ErrnoMsg) /* 128 */
-#endif
-#ifndef Tcl_Eval
#define Tcl_Eval \
(tclStubsPtr->tcl_Eval) /* 129 */
-#endif
-#ifndef Tcl_EvalFile
#define Tcl_EvalFile \
(tclStubsPtr->tcl_EvalFile) /* 130 */
-#endif
-#ifndef Tcl_EvalObj
#define Tcl_EvalObj \
(tclStubsPtr->tcl_EvalObj) /* 131 */
-#endif
-#ifndef Tcl_EventuallyFree
#define Tcl_EventuallyFree \
(tclStubsPtr->tcl_EventuallyFree) /* 132 */
-#endif
-#ifndef Tcl_Exit
#define Tcl_Exit \
(tclStubsPtr->tcl_Exit) /* 133 */
-#endif
-#ifndef Tcl_ExposeCommand
#define Tcl_ExposeCommand \
(tclStubsPtr->tcl_ExposeCommand) /* 134 */
-#endif
-#ifndef Tcl_ExprBoolean
#define Tcl_ExprBoolean \
(tclStubsPtr->tcl_ExprBoolean) /* 135 */
-#endif
-#ifndef Tcl_ExprBooleanObj
#define Tcl_ExprBooleanObj \
(tclStubsPtr->tcl_ExprBooleanObj) /* 136 */
-#endif
-#ifndef Tcl_ExprDouble
#define Tcl_ExprDouble \
(tclStubsPtr->tcl_ExprDouble) /* 137 */
-#endif
-#ifndef Tcl_ExprDoubleObj
#define Tcl_ExprDoubleObj \
(tclStubsPtr->tcl_ExprDoubleObj) /* 138 */
-#endif
-#ifndef Tcl_ExprLong
#define Tcl_ExprLong \
(tclStubsPtr->tcl_ExprLong) /* 139 */
-#endif
-#ifndef Tcl_ExprLongObj
#define Tcl_ExprLongObj \
(tclStubsPtr->tcl_ExprLongObj) /* 140 */
-#endif
-#ifndef Tcl_ExprObj
#define Tcl_ExprObj \
(tclStubsPtr->tcl_ExprObj) /* 141 */
-#endif
-#ifndef Tcl_ExprString
#define Tcl_ExprString \
(tclStubsPtr->tcl_ExprString) /* 142 */
-#endif
-#ifndef Tcl_Finalize
#define Tcl_Finalize \
(tclStubsPtr->tcl_Finalize) /* 143 */
-#endif
-#ifndef Tcl_FindExecutable
#define Tcl_FindExecutable \
(tclStubsPtr->tcl_FindExecutable) /* 144 */
-#endif
-#ifndef Tcl_FirstHashEntry
#define Tcl_FirstHashEntry \
(tclStubsPtr->tcl_FirstHashEntry) /* 145 */
-#endif
-#ifndef Tcl_Flush
#define Tcl_Flush \
(tclStubsPtr->tcl_Flush) /* 146 */
-#endif
-#ifndef Tcl_FreeResult
#define Tcl_FreeResult \
(tclStubsPtr->tcl_FreeResult) /* 147 */
-#endif
-#ifndef Tcl_GetAlias
#define Tcl_GetAlias \
(tclStubsPtr->tcl_GetAlias) /* 148 */
-#endif
-#ifndef Tcl_GetAliasObj
#define Tcl_GetAliasObj \
(tclStubsPtr->tcl_GetAliasObj) /* 149 */
-#endif
-#ifndef Tcl_GetAssocData
#define Tcl_GetAssocData \
(tclStubsPtr->tcl_GetAssocData) /* 150 */
-#endif
-#ifndef Tcl_GetChannel
#define Tcl_GetChannel \
(tclStubsPtr->tcl_GetChannel) /* 151 */
-#endif
-#ifndef Tcl_GetChannelBufferSize
#define Tcl_GetChannelBufferSize \
(tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */
-#endif
-#ifndef Tcl_GetChannelHandle
#define Tcl_GetChannelHandle \
(tclStubsPtr->tcl_GetChannelHandle) /* 153 */
-#endif
-#ifndef Tcl_GetChannelInstanceData
#define Tcl_GetChannelInstanceData \
(tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */
-#endif
-#ifndef Tcl_GetChannelMode
#define Tcl_GetChannelMode \
(tclStubsPtr->tcl_GetChannelMode) /* 155 */
-#endif
-#ifndef Tcl_GetChannelName
#define Tcl_GetChannelName \
(tclStubsPtr->tcl_GetChannelName) /* 156 */
-#endif
-#ifndef Tcl_GetChannelOption
#define Tcl_GetChannelOption \
(tclStubsPtr->tcl_GetChannelOption) /* 157 */
-#endif
-#ifndef Tcl_GetChannelType
#define Tcl_GetChannelType \
(tclStubsPtr->tcl_GetChannelType) /* 158 */
-#endif
-#ifndef Tcl_GetCommandInfo
#define Tcl_GetCommandInfo \
(tclStubsPtr->tcl_GetCommandInfo) /* 159 */
-#endif
-#ifndef Tcl_GetCommandName
#define Tcl_GetCommandName \
(tclStubsPtr->tcl_GetCommandName) /* 160 */
-#endif
-#ifndef Tcl_GetErrno
#define Tcl_GetErrno \
(tclStubsPtr->tcl_GetErrno) /* 161 */
-#endif
-#ifndef Tcl_GetHostName
#define Tcl_GetHostName \
(tclStubsPtr->tcl_GetHostName) /* 162 */
-#endif
-#ifndef Tcl_GetInterpPath
#define Tcl_GetInterpPath \
(tclStubsPtr->tcl_GetInterpPath) /* 163 */
-#endif
-#ifndef Tcl_GetMaster
#define Tcl_GetMaster \
(tclStubsPtr->tcl_GetMaster) /* 164 */
-#endif
-#ifndef Tcl_GetNameOfExecutable
#define Tcl_GetNameOfExecutable \
(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
-#endif
-#ifndef Tcl_GetObjResult
#define Tcl_GetObjResult \
(tclStubsPtr->tcl_GetObjResult) /* 166 */
-#endif
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
(tclStubsPtr->tcl_GetOpenFile) /* 167 */
-#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
(tclStubsPtr->tcl_GetOpenFile) /* 167 */
-#endif
#endif /* MACOSX */
-#ifndef Tcl_GetPathType
#define Tcl_GetPathType \
(tclStubsPtr->tcl_GetPathType) /* 168 */
-#endif
-#ifndef Tcl_Gets
#define Tcl_Gets \
(tclStubsPtr->tcl_Gets) /* 169 */
-#endif
-#ifndef Tcl_GetsObj
#define Tcl_GetsObj \
(tclStubsPtr->tcl_GetsObj) /* 170 */
-#endif
-#ifndef Tcl_GetServiceMode
#define Tcl_GetServiceMode \
(tclStubsPtr->tcl_GetServiceMode) /* 171 */
-#endif
-#ifndef Tcl_GetSlave
#define Tcl_GetSlave \
(tclStubsPtr->tcl_GetSlave) /* 172 */
-#endif
-#ifndef Tcl_GetStdChannel
#define Tcl_GetStdChannel \
(tclStubsPtr->tcl_GetStdChannel) /* 173 */
-#endif
-#ifndef Tcl_GetStringResult
#define Tcl_GetStringResult \
(tclStubsPtr->tcl_GetStringResult) /* 174 */
-#endif
-#ifndef Tcl_GetVar
#define Tcl_GetVar \
(tclStubsPtr->tcl_GetVar) /* 175 */
-#endif
-#ifndef Tcl_GetVar2
#define Tcl_GetVar2 \
(tclStubsPtr->tcl_GetVar2) /* 176 */
-#endif
-#ifndef Tcl_GlobalEval
#define Tcl_GlobalEval \
(tclStubsPtr->tcl_GlobalEval) /* 177 */
-#endif
-#ifndef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj \
(tclStubsPtr->tcl_GlobalEvalObj) /* 178 */
-#endif
-#ifndef Tcl_HideCommand
#define Tcl_HideCommand \
(tclStubsPtr->tcl_HideCommand) /* 179 */
-#endif
-#ifndef Tcl_Init
#define Tcl_Init \
(tclStubsPtr->tcl_Init) /* 180 */
-#endif
-#ifndef Tcl_InitHashTable
#define Tcl_InitHashTable \
(tclStubsPtr->tcl_InitHashTable) /* 181 */
-#endif
-#ifndef Tcl_InputBlocked
#define Tcl_InputBlocked \
(tclStubsPtr->tcl_InputBlocked) /* 182 */
-#endif
-#ifndef Tcl_InputBuffered
#define Tcl_InputBuffered \
(tclStubsPtr->tcl_InputBuffered) /* 183 */
-#endif
-#ifndef Tcl_InterpDeleted
#define Tcl_InterpDeleted \
(tclStubsPtr->tcl_InterpDeleted) /* 184 */
-#endif
-#ifndef Tcl_IsSafe
#define Tcl_IsSafe \
(tclStubsPtr->tcl_IsSafe) /* 185 */
-#endif
-#ifndef Tcl_JoinPath
#define Tcl_JoinPath \
(tclStubsPtr->tcl_JoinPath) /* 186 */
-#endif
-#ifndef Tcl_LinkVar
#define Tcl_LinkVar \
(tclStubsPtr->tcl_LinkVar) /* 187 */
-#endif
/* Slot 188 is reserved */
-#ifndef Tcl_MakeFileChannel
#define Tcl_MakeFileChannel \
(tclStubsPtr->tcl_MakeFileChannel) /* 189 */
-#endif
-#ifndef Tcl_MakeSafe
#define Tcl_MakeSafe \
(tclStubsPtr->tcl_MakeSafe) /* 190 */
-#endif
-#ifndef Tcl_MakeTcpClientChannel
#define Tcl_MakeTcpClientChannel \
(tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */
-#endif
-#ifndef Tcl_Merge
#define Tcl_Merge \
(tclStubsPtr->tcl_Merge) /* 192 */
-#endif
-#ifndef Tcl_NextHashEntry
#define Tcl_NextHashEntry \
(tclStubsPtr->tcl_NextHashEntry) /* 193 */
-#endif
-#ifndef Tcl_NotifyChannel
#define Tcl_NotifyChannel \
(tclStubsPtr->tcl_NotifyChannel) /* 194 */
-#endif
-#ifndef Tcl_ObjGetVar2
#define Tcl_ObjGetVar2 \
(tclStubsPtr->tcl_ObjGetVar2) /* 195 */
-#endif
-#ifndef Tcl_ObjSetVar2
#define Tcl_ObjSetVar2 \
(tclStubsPtr->tcl_ObjSetVar2) /* 196 */
-#endif
-#ifndef Tcl_OpenCommandChannel
#define Tcl_OpenCommandChannel \
(tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
-#endif
-#ifndef Tcl_OpenFileChannel
#define Tcl_OpenFileChannel \
(tclStubsPtr->tcl_OpenFileChannel) /* 198 */
-#endif
-#ifndef Tcl_OpenTcpClient
#define Tcl_OpenTcpClient \
(tclStubsPtr->tcl_OpenTcpClient) /* 199 */
-#endif
-#ifndef Tcl_OpenTcpServer
#define Tcl_OpenTcpServer \
(tclStubsPtr->tcl_OpenTcpServer) /* 200 */
-#endif
-#ifndef Tcl_Preserve
#define Tcl_Preserve \
(tclStubsPtr->tcl_Preserve) /* 201 */
-#endif
-#ifndef Tcl_PrintDouble
#define Tcl_PrintDouble \
(tclStubsPtr->tcl_PrintDouble) /* 202 */
-#endif
-#ifndef Tcl_PutEnv
#define Tcl_PutEnv \
(tclStubsPtr->tcl_PutEnv) /* 203 */
-#endif
-#ifndef Tcl_PosixError
#define Tcl_PosixError \
(tclStubsPtr->tcl_PosixError) /* 204 */
-#endif
-#ifndef Tcl_QueueEvent
#define Tcl_QueueEvent \
(tclStubsPtr->tcl_QueueEvent) /* 205 */
-#endif
-#ifndef Tcl_Read
#define Tcl_Read \
(tclStubsPtr->tcl_Read) /* 206 */
-#endif
-#ifndef Tcl_ReapDetachedProcs
#define Tcl_ReapDetachedProcs \
(tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
-#endif
-#ifndef Tcl_RecordAndEval
#define Tcl_RecordAndEval \
(tclStubsPtr->tcl_RecordAndEval) /* 208 */
-#endif
-#ifndef Tcl_RecordAndEvalObj
#define Tcl_RecordAndEvalObj \
(tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */
-#endif
-#ifndef Tcl_RegisterChannel
#define Tcl_RegisterChannel \
(tclStubsPtr->tcl_RegisterChannel) /* 210 */
-#endif
-#ifndef Tcl_RegisterObjType
#define Tcl_RegisterObjType \
(tclStubsPtr->tcl_RegisterObjType) /* 211 */
-#endif
-#ifndef Tcl_RegExpCompile
#define Tcl_RegExpCompile \
(tclStubsPtr->tcl_RegExpCompile) /* 212 */
-#endif
-#ifndef Tcl_RegExpExec
#define Tcl_RegExpExec \
(tclStubsPtr->tcl_RegExpExec) /* 213 */
-#endif
-#ifndef Tcl_RegExpMatch
#define Tcl_RegExpMatch \
(tclStubsPtr->tcl_RegExpMatch) /* 214 */
-#endif
-#ifndef Tcl_RegExpRange
#define Tcl_RegExpRange \
(tclStubsPtr->tcl_RegExpRange) /* 215 */
-#endif
-#ifndef Tcl_Release
#define Tcl_Release \
(tclStubsPtr->tcl_Release) /* 216 */
-#endif
-#ifndef Tcl_ResetResult
#define Tcl_ResetResult \
(tclStubsPtr->tcl_ResetResult) /* 217 */
-#endif
-#ifndef Tcl_ScanElement
#define Tcl_ScanElement \
(tclStubsPtr->tcl_ScanElement) /* 218 */
-#endif
-#ifndef Tcl_ScanCountedElement
#define Tcl_ScanCountedElement \
(tclStubsPtr->tcl_ScanCountedElement) /* 219 */
-#endif
-#ifndef Tcl_SeekOld
#define Tcl_SeekOld \
(tclStubsPtr->tcl_SeekOld) /* 220 */
-#endif
-#ifndef Tcl_ServiceAll
#define Tcl_ServiceAll \
(tclStubsPtr->tcl_ServiceAll) /* 221 */
-#endif
-#ifndef Tcl_ServiceEvent
#define Tcl_ServiceEvent \
(tclStubsPtr->tcl_ServiceEvent) /* 222 */
-#endif
-#ifndef Tcl_SetAssocData
#define Tcl_SetAssocData \
(tclStubsPtr->tcl_SetAssocData) /* 223 */
-#endif
-#ifndef Tcl_SetChannelBufferSize
#define Tcl_SetChannelBufferSize \
(tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */
-#endif
-#ifndef Tcl_SetChannelOption
#define Tcl_SetChannelOption \
(tclStubsPtr->tcl_SetChannelOption) /* 225 */
-#endif
-#ifndef Tcl_SetCommandInfo
#define Tcl_SetCommandInfo \
(tclStubsPtr->tcl_SetCommandInfo) /* 226 */
-#endif
-#ifndef Tcl_SetErrno
#define Tcl_SetErrno \
(tclStubsPtr->tcl_SetErrno) /* 227 */
-#endif
-#ifndef Tcl_SetErrorCode
#define Tcl_SetErrorCode \
(tclStubsPtr->tcl_SetErrorCode) /* 228 */
-#endif
-#ifndef Tcl_SetMaxBlockTime
#define Tcl_SetMaxBlockTime \
(tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */
-#endif
-#ifndef Tcl_SetPanicProc
#define Tcl_SetPanicProc \
(tclStubsPtr->tcl_SetPanicProc) /* 230 */
-#endif
-#ifndef Tcl_SetRecursionLimit
#define Tcl_SetRecursionLimit \
(tclStubsPtr->tcl_SetRecursionLimit) /* 231 */
-#endif
-#ifndef Tcl_SetResult
#define Tcl_SetResult \
(tclStubsPtr->tcl_SetResult) /* 232 */
-#endif
-#ifndef Tcl_SetServiceMode
#define Tcl_SetServiceMode \
(tclStubsPtr->tcl_SetServiceMode) /* 233 */
-#endif
-#ifndef Tcl_SetObjErrorCode
#define Tcl_SetObjErrorCode \
(tclStubsPtr->tcl_SetObjErrorCode) /* 234 */
-#endif
-#ifndef Tcl_SetObjResult
#define Tcl_SetObjResult \
(tclStubsPtr->tcl_SetObjResult) /* 235 */
-#endif
-#ifndef Tcl_SetStdChannel
#define Tcl_SetStdChannel \
(tclStubsPtr->tcl_SetStdChannel) /* 236 */
-#endif
-#ifndef Tcl_SetVar
#define Tcl_SetVar \
(tclStubsPtr->tcl_SetVar) /* 237 */
-#endif
-#ifndef Tcl_SetVar2
#define Tcl_SetVar2 \
(tclStubsPtr->tcl_SetVar2) /* 238 */
-#endif
-#ifndef Tcl_SignalId
#define Tcl_SignalId \
(tclStubsPtr->tcl_SignalId) /* 239 */
-#endif
-#ifndef Tcl_SignalMsg
#define Tcl_SignalMsg \
(tclStubsPtr->tcl_SignalMsg) /* 240 */
-#endif
-#ifndef Tcl_SourceRCFile
#define Tcl_SourceRCFile \
(tclStubsPtr->tcl_SourceRCFile) /* 241 */
-#endif
-#ifndef Tcl_SplitList
#define Tcl_SplitList \
(tclStubsPtr->tcl_SplitList) /* 242 */
-#endif
-#ifndef Tcl_SplitPath
#define Tcl_SplitPath \
(tclStubsPtr->tcl_SplitPath) /* 243 */
-#endif
-#ifndef Tcl_StaticPackage
#define Tcl_StaticPackage \
(tclStubsPtr->tcl_StaticPackage) /* 244 */
-#endif
-#ifndef Tcl_StringMatch
#define Tcl_StringMatch \
(tclStubsPtr->tcl_StringMatch) /* 245 */
-#endif
-#ifndef Tcl_TellOld
#define Tcl_TellOld \
(tclStubsPtr->tcl_TellOld) /* 246 */
-#endif
-#ifndef Tcl_TraceVar
#define Tcl_TraceVar \
(tclStubsPtr->tcl_TraceVar) /* 247 */
-#endif
-#ifndef Tcl_TraceVar2
#define Tcl_TraceVar2 \
(tclStubsPtr->tcl_TraceVar2) /* 248 */
-#endif
-#ifndef Tcl_TranslateFileName
#define Tcl_TranslateFileName \
(tclStubsPtr->tcl_TranslateFileName) /* 249 */
-#endif
-#ifndef Tcl_Ungets
#define Tcl_Ungets \
(tclStubsPtr->tcl_Ungets) /* 250 */
-#endif
-#ifndef Tcl_UnlinkVar
#define Tcl_UnlinkVar \
(tclStubsPtr->tcl_UnlinkVar) /* 251 */
-#endif
-#ifndef Tcl_UnregisterChannel
#define Tcl_UnregisterChannel \
(tclStubsPtr->tcl_UnregisterChannel) /* 252 */
-#endif
-#ifndef Tcl_UnsetVar
#define Tcl_UnsetVar \
(tclStubsPtr->tcl_UnsetVar) /* 253 */
-#endif
-#ifndef Tcl_UnsetVar2
#define Tcl_UnsetVar2 \
(tclStubsPtr->tcl_UnsetVar2) /* 254 */
-#endif
-#ifndef Tcl_UntraceVar
#define Tcl_UntraceVar \
(tclStubsPtr->tcl_UntraceVar) /* 255 */
-#endif
-#ifndef Tcl_UntraceVar2
#define Tcl_UntraceVar2 \
(tclStubsPtr->tcl_UntraceVar2) /* 256 */
-#endif
-#ifndef Tcl_UpdateLinkedVar
#define Tcl_UpdateLinkedVar \
(tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */
-#endif
-#ifndef Tcl_UpVar
#define Tcl_UpVar \
(tclStubsPtr->tcl_UpVar) /* 258 */
-#endif
-#ifndef Tcl_UpVar2
#define Tcl_UpVar2 \
(tclStubsPtr->tcl_UpVar2) /* 259 */
-#endif
-#ifndef Tcl_VarEval
#define Tcl_VarEval \
(tclStubsPtr->tcl_VarEval) /* 260 */
-#endif
-#ifndef Tcl_VarTraceInfo
#define Tcl_VarTraceInfo \
(tclStubsPtr->tcl_VarTraceInfo) /* 261 */
-#endif
-#ifndef Tcl_VarTraceInfo2
#define Tcl_VarTraceInfo2 \
(tclStubsPtr->tcl_VarTraceInfo2) /* 262 */
-#endif
-#ifndef Tcl_Write
#define Tcl_Write \
(tclStubsPtr->tcl_Write) /* 263 */
-#endif
-#ifndef Tcl_WrongNumArgs
#define Tcl_WrongNumArgs \
(tclStubsPtr->tcl_WrongNumArgs) /* 264 */
-#endif
-#ifndef Tcl_DumpActiveMemory
#define Tcl_DumpActiveMemory \
(tclStubsPtr->tcl_DumpActiveMemory) /* 265 */
-#endif
-#ifndef Tcl_ValidateAllMemory
#define Tcl_ValidateAllMemory \
(tclStubsPtr->tcl_ValidateAllMemory) /* 266 */
-#endif
-#ifndef Tcl_AppendResultVA
#define Tcl_AppendResultVA \
(tclStubsPtr->tcl_AppendResultVA) /* 267 */
-#endif
-#ifndef Tcl_AppendStringsToObjVA
#define Tcl_AppendStringsToObjVA \
(tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */
-#endif
-#ifndef Tcl_HashStats
#define Tcl_HashStats \
(tclStubsPtr->tcl_HashStats) /* 269 */
-#endif
-#ifndef Tcl_ParseVar
#define Tcl_ParseVar \
(tclStubsPtr->tcl_ParseVar) /* 270 */
-#endif
-#ifndef Tcl_PkgPresent
#define Tcl_PkgPresent \
(tclStubsPtr->tcl_PkgPresent) /* 271 */
-#endif
-#ifndef Tcl_PkgPresentEx
#define Tcl_PkgPresentEx \
(tclStubsPtr->tcl_PkgPresentEx) /* 272 */
-#endif
-#ifndef Tcl_PkgProvide
#define Tcl_PkgProvide \
(tclStubsPtr->tcl_PkgProvide) /* 273 */
-#endif
-#ifndef Tcl_PkgRequire
#define Tcl_PkgRequire \
(tclStubsPtr->tcl_PkgRequire) /* 274 */
-#endif
-#ifndef Tcl_SetErrorCodeVA
#define Tcl_SetErrorCodeVA \
(tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */
-#endif
-#ifndef Tcl_VarEvalVA
#define Tcl_VarEvalVA \
(tclStubsPtr->tcl_VarEvalVA) /* 276 */
-#endif
-#ifndef Tcl_WaitPid
#define Tcl_WaitPid \
(tclStubsPtr->tcl_WaitPid) /* 277 */
-#endif
-#ifndef Tcl_PanicVA
#define Tcl_PanicVA \
(tclStubsPtr->tcl_PanicVA) /* 278 */
-#endif
-#ifndef Tcl_GetVersion
#define Tcl_GetVersion \
(tclStubsPtr->tcl_GetVersion) /* 279 */
-#endif
-#ifndef Tcl_InitMemory
#define Tcl_InitMemory \
(tclStubsPtr->tcl_InitMemory) /* 280 */
-#endif
-#ifndef Tcl_StackChannel
#define Tcl_StackChannel \
(tclStubsPtr->tcl_StackChannel) /* 281 */
-#endif
-#ifndef Tcl_UnstackChannel
#define Tcl_UnstackChannel \
(tclStubsPtr->tcl_UnstackChannel) /* 282 */
-#endif
-#ifndef Tcl_GetStackedChannel
#define Tcl_GetStackedChannel \
(tclStubsPtr->tcl_GetStackedChannel) /* 283 */
-#endif
-#ifndef Tcl_SetMainLoop
#define Tcl_SetMainLoop \
(tclStubsPtr->tcl_SetMainLoop) /* 284 */
-#endif
/* Slot 285 is reserved */
-#ifndef Tcl_AppendObjToObj
#define Tcl_AppendObjToObj \
(tclStubsPtr->tcl_AppendObjToObj) /* 286 */
-#endif
-#ifndef Tcl_CreateEncoding
#define Tcl_CreateEncoding \
(tclStubsPtr->tcl_CreateEncoding) /* 287 */
-#endif
-#ifndef Tcl_CreateThreadExitHandler
#define Tcl_CreateThreadExitHandler \
(tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */
-#endif
-#ifndef Tcl_DeleteThreadExitHandler
#define Tcl_DeleteThreadExitHandler \
(tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */
-#endif
-#ifndef Tcl_DiscardResult
#define Tcl_DiscardResult \
(tclStubsPtr->tcl_DiscardResult) /* 290 */
-#endif
-#ifndef Tcl_EvalEx
#define Tcl_EvalEx \
(tclStubsPtr->tcl_EvalEx) /* 291 */
-#endif
-#ifndef Tcl_EvalObjv
#define Tcl_EvalObjv \
(tclStubsPtr->tcl_EvalObjv) /* 292 */
-#endif
-#ifndef Tcl_EvalObjEx
#define Tcl_EvalObjEx \
(tclStubsPtr->tcl_EvalObjEx) /* 293 */
-#endif
-#ifndef Tcl_ExitThread
#define Tcl_ExitThread \
(tclStubsPtr->tcl_ExitThread) /* 294 */
-#endif
-#ifndef Tcl_ExternalToUtf
#define Tcl_ExternalToUtf \
(tclStubsPtr->tcl_ExternalToUtf) /* 295 */
-#endif
-#ifndef Tcl_ExternalToUtfDString
#define Tcl_ExternalToUtfDString \
(tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */
-#endif
-#ifndef Tcl_FinalizeThread
#define Tcl_FinalizeThread \
(tclStubsPtr->tcl_FinalizeThread) /* 297 */
-#endif
-#ifndef Tcl_FinalizeNotifier
#define Tcl_FinalizeNotifier \
(tclStubsPtr->tcl_FinalizeNotifier) /* 298 */
-#endif
-#ifndef Tcl_FreeEncoding
#define Tcl_FreeEncoding \
(tclStubsPtr->tcl_FreeEncoding) /* 299 */
-#endif
-#ifndef Tcl_GetCurrentThread
#define Tcl_GetCurrentThread \
(tclStubsPtr->tcl_GetCurrentThread) /* 300 */
-#endif
-#ifndef Tcl_GetEncoding
#define Tcl_GetEncoding \
(tclStubsPtr->tcl_GetEncoding) /* 301 */
-#endif
-#ifndef Tcl_GetEncodingName
#define Tcl_GetEncodingName \
(tclStubsPtr->tcl_GetEncodingName) /* 302 */
-#endif
-#ifndef Tcl_GetEncodingNames
#define Tcl_GetEncodingNames \
(tclStubsPtr->tcl_GetEncodingNames) /* 303 */
-#endif
-#ifndef Tcl_GetIndexFromObjStruct
#define Tcl_GetIndexFromObjStruct \
(tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */
-#endif
-#ifndef Tcl_GetThreadData
#define Tcl_GetThreadData \
(tclStubsPtr->tcl_GetThreadData) /* 305 */
-#endif
-#ifndef Tcl_GetVar2Ex
#define Tcl_GetVar2Ex \
(tclStubsPtr->tcl_GetVar2Ex) /* 306 */
-#endif
-#ifndef Tcl_InitNotifier
#define Tcl_InitNotifier \
(tclStubsPtr->tcl_InitNotifier) /* 307 */
-#endif
-#ifndef Tcl_MutexLock
#define Tcl_MutexLock \
(tclStubsPtr->tcl_MutexLock) /* 308 */
-#endif
-#ifndef Tcl_MutexUnlock
#define Tcl_MutexUnlock \
(tclStubsPtr->tcl_MutexUnlock) /* 309 */
-#endif
-#ifndef Tcl_ConditionNotify
#define Tcl_ConditionNotify \
(tclStubsPtr->tcl_ConditionNotify) /* 310 */
-#endif
-#ifndef Tcl_ConditionWait
#define Tcl_ConditionWait \
(tclStubsPtr->tcl_ConditionWait) /* 311 */
-#endif
-#ifndef Tcl_NumUtfChars
#define Tcl_NumUtfChars \
(tclStubsPtr->tcl_NumUtfChars) /* 312 */
-#endif
-#ifndef Tcl_ReadChars
#define Tcl_ReadChars \
(tclStubsPtr->tcl_ReadChars) /* 313 */
-#endif
-#ifndef Tcl_RestoreResult
#define Tcl_RestoreResult \
(tclStubsPtr->tcl_RestoreResult) /* 314 */
-#endif
-#ifndef Tcl_SaveResult
#define Tcl_SaveResult \
(tclStubsPtr->tcl_SaveResult) /* 315 */
-#endif
-#ifndef Tcl_SetSystemEncoding
#define Tcl_SetSystemEncoding \
(tclStubsPtr->tcl_SetSystemEncoding) /* 316 */
-#endif
-#ifndef Tcl_SetVar2Ex
#define Tcl_SetVar2Ex \
(tclStubsPtr->tcl_SetVar2Ex) /* 317 */
-#endif
-#ifndef Tcl_ThreadAlert
#define Tcl_ThreadAlert \
(tclStubsPtr->tcl_ThreadAlert) /* 318 */
-#endif
-#ifndef Tcl_ThreadQueueEvent
#define Tcl_ThreadQueueEvent \
(tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */
-#endif
-#ifndef Tcl_UniCharAtIndex
#define Tcl_UniCharAtIndex \
(tclStubsPtr->tcl_UniCharAtIndex) /* 320 */
-#endif
-#ifndef Tcl_UniCharToLower
#define Tcl_UniCharToLower \
(tclStubsPtr->tcl_UniCharToLower) /* 321 */
-#endif
-#ifndef Tcl_UniCharToTitle
#define Tcl_UniCharToTitle \
(tclStubsPtr->tcl_UniCharToTitle) /* 322 */
-#endif
-#ifndef Tcl_UniCharToUpper
#define Tcl_UniCharToUpper \
(tclStubsPtr->tcl_UniCharToUpper) /* 323 */
-#endif
-#ifndef Tcl_UniCharToUtf
#define Tcl_UniCharToUtf \
(tclStubsPtr->tcl_UniCharToUtf) /* 324 */
-#endif
-#ifndef Tcl_UtfAtIndex
#define Tcl_UtfAtIndex \
(tclStubsPtr->tcl_UtfAtIndex) /* 325 */
-#endif
-#ifndef Tcl_UtfCharComplete
#define Tcl_UtfCharComplete \
(tclStubsPtr->tcl_UtfCharComplete) /* 326 */
-#endif
-#ifndef Tcl_UtfBackslash
#define Tcl_UtfBackslash \
(tclStubsPtr->tcl_UtfBackslash) /* 327 */
-#endif
-#ifndef Tcl_UtfFindFirst
#define Tcl_UtfFindFirst \
(tclStubsPtr->tcl_UtfFindFirst) /* 328 */
-#endif
-#ifndef Tcl_UtfFindLast
#define Tcl_UtfFindLast \
(tclStubsPtr->tcl_UtfFindLast) /* 329 */
-#endif
-#ifndef Tcl_UtfNext
#define Tcl_UtfNext \
(tclStubsPtr->tcl_UtfNext) /* 330 */
-#endif
-#ifndef Tcl_UtfPrev
#define Tcl_UtfPrev \
(tclStubsPtr->tcl_UtfPrev) /* 331 */
-#endif
-#ifndef Tcl_UtfToExternal
#define Tcl_UtfToExternal \
(tclStubsPtr->tcl_UtfToExternal) /* 332 */
-#endif
-#ifndef Tcl_UtfToExternalDString
#define Tcl_UtfToExternalDString \
(tclStubsPtr->tcl_UtfToExternalDString) /* 333 */
-#endif
-#ifndef Tcl_UtfToLower
#define Tcl_UtfToLower \
(tclStubsPtr->tcl_UtfToLower) /* 334 */
-#endif
-#ifndef Tcl_UtfToTitle
#define Tcl_UtfToTitle \
(tclStubsPtr->tcl_UtfToTitle) /* 335 */
-#endif
-#ifndef Tcl_UtfToUniChar
#define Tcl_UtfToUniChar \
(tclStubsPtr->tcl_UtfToUniChar) /* 336 */
-#endif
-#ifndef Tcl_UtfToUpper
#define Tcl_UtfToUpper \
(tclStubsPtr->tcl_UtfToUpper) /* 337 */
-#endif
-#ifndef Tcl_WriteChars
#define Tcl_WriteChars \
(tclStubsPtr->tcl_WriteChars) /* 338 */
-#endif
-#ifndef Tcl_WriteObj
#define Tcl_WriteObj \
(tclStubsPtr->tcl_WriteObj) /* 339 */
-#endif
-#ifndef Tcl_GetString
#define Tcl_GetString \
(tclStubsPtr->tcl_GetString) /* 340 */
-#endif
-#ifndef Tcl_GetDefaultEncodingDir
#define Tcl_GetDefaultEncodingDir \
(tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */
-#endif
-#ifndef Tcl_SetDefaultEncodingDir
#define Tcl_SetDefaultEncodingDir \
(tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */
-#endif
-#ifndef Tcl_AlertNotifier
#define Tcl_AlertNotifier \
(tclStubsPtr->tcl_AlertNotifier) /* 343 */
-#endif
-#ifndef Tcl_ServiceModeHook
#define Tcl_ServiceModeHook \
(tclStubsPtr->tcl_ServiceModeHook) /* 344 */
-#endif
-#ifndef Tcl_UniCharIsAlnum
#define Tcl_UniCharIsAlnum \
(tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */
-#endif
-#ifndef Tcl_UniCharIsAlpha
#define Tcl_UniCharIsAlpha \
(tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */
-#endif
-#ifndef Tcl_UniCharIsDigit
#define Tcl_UniCharIsDigit \
(tclStubsPtr->tcl_UniCharIsDigit) /* 347 */
-#endif
-#ifndef Tcl_UniCharIsLower
#define Tcl_UniCharIsLower \
(tclStubsPtr->tcl_UniCharIsLower) /* 348 */
-#endif
-#ifndef Tcl_UniCharIsSpace
#define Tcl_UniCharIsSpace \
(tclStubsPtr->tcl_UniCharIsSpace) /* 349 */
-#endif
-#ifndef Tcl_UniCharIsUpper
#define Tcl_UniCharIsUpper \
(tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
-#endif
-#ifndef Tcl_UniCharIsWordChar
#define Tcl_UniCharIsWordChar \
(tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
-#endif
-#ifndef Tcl_UniCharLen
#define Tcl_UniCharLen \
(tclStubsPtr->tcl_UniCharLen) /* 352 */
-#endif
-#ifndef Tcl_UniCharNcmp
#define Tcl_UniCharNcmp \
(tclStubsPtr->tcl_UniCharNcmp) /* 353 */
-#endif
-#ifndef Tcl_UniCharToUtfDString
#define Tcl_UniCharToUtfDString \
(tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
-#endif
-#ifndef Tcl_UtfToUniCharDString
#define Tcl_UtfToUniCharDString \
(tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
-#endif
-#ifndef Tcl_GetRegExpFromObj
#define Tcl_GetRegExpFromObj \
(tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
-#endif
-#ifndef Tcl_EvalTokens
#define Tcl_EvalTokens \
(tclStubsPtr->tcl_EvalTokens) /* 357 */
-#endif
-#ifndef Tcl_FreeParse
#define Tcl_FreeParse \
(tclStubsPtr->tcl_FreeParse) /* 358 */
-#endif
-#ifndef Tcl_LogCommandInfo
#define Tcl_LogCommandInfo \
(tclStubsPtr->tcl_LogCommandInfo) /* 359 */
-#endif
-#ifndef Tcl_ParseBraces
#define Tcl_ParseBraces \
(tclStubsPtr->tcl_ParseBraces) /* 360 */
-#endif
-#ifndef Tcl_ParseCommand
#define Tcl_ParseCommand \
(tclStubsPtr->tcl_ParseCommand) /* 361 */
-#endif
-#ifndef Tcl_ParseExpr
#define Tcl_ParseExpr \
(tclStubsPtr->tcl_ParseExpr) /* 362 */
-#endif
-#ifndef Tcl_ParseQuotedString
#define Tcl_ParseQuotedString \
(tclStubsPtr->tcl_ParseQuotedString) /* 363 */
-#endif
-#ifndef Tcl_ParseVarName
#define Tcl_ParseVarName \
(tclStubsPtr->tcl_ParseVarName) /* 364 */
-#endif
-#ifndef Tcl_GetCwd
#define Tcl_GetCwd \
(tclStubsPtr->tcl_GetCwd) /* 365 */
-#endif
-#ifndef Tcl_Chdir
#define Tcl_Chdir \
(tclStubsPtr->tcl_Chdir) /* 366 */
-#endif
-#ifndef Tcl_Access
#define Tcl_Access \
(tclStubsPtr->tcl_Access) /* 367 */
-#endif
-#ifndef Tcl_Stat
#define Tcl_Stat \
(tclStubsPtr->tcl_Stat) /* 368 */
-#endif
-#ifndef Tcl_UtfNcmp
#define Tcl_UtfNcmp \
(tclStubsPtr->tcl_UtfNcmp) /* 369 */
-#endif
-#ifndef Tcl_UtfNcasecmp
#define Tcl_UtfNcasecmp \
(tclStubsPtr->tcl_UtfNcasecmp) /* 370 */
-#endif
-#ifndef Tcl_StringCaseMatch
#define Tcl_StringCaseMatch \
(tclStubsPtr->tcl_StringCaseMatch) /* 371 */
-#endif
-#ifndef Tcl_UniCharIsControl
#define Tcl_UniCharIsControl \
(tclStubsPtr->tcl_UniCharIsControl) /* 372 */
-#endif
-#ifndef Tcl_UniCharIsGraph
#define Tcl_UniCharIsGraph \
(tclStubsPtr->tcl_UniCharIsGraph) /* 373 */
-#endif
-#ifndef Tcl_UniCharIsPrint
#define Tcl_UniCharIsPrint \
(tclStubsPtr->tcl_UniCharIsPrint) /* 374 */
-#endif
-#ifndef Tcl_UniCharIsPunct
#define Tcl_UniCharIsPunct \
(tclStubsPtr->tcl_UniCharIsPunct) /* 375 */
-#endif
-#ifndef Tcl_RegExpExecObj
#define Tcl_RegExpExecObj \
(tclStubsPtr->tcl_RegExpExecObj) /* 376 */
-#endif
-#ifndef Tcl_RegExpGetInfo
#define Tcl_RegExpGetInfo \
(tclStubsPtr->tcl_RegExpGetInfo) /* 377 */
-#endif
-#ifndef Tcl_NewUnicodeObj
#define Tcl_NewUnicodeObj \
(tclStubsPtr->tcl_NewUnicodeObj) /* 378 */
-#endif
-#ifndef Tcl_SetUnicodeObj
#define Tcl_SetUnicodeObj \
(tclStubsPtr->tcl_SetUnicodeObj) /* 379 */
-#endif
-#ifndef Tcl_GetCharLength
#define Tcl_GetCharLength \
(tclStubsPtr->tcl_GetCharLength) /* 380 */
-#endif
-#ifndef Tcl_GetUniChar
#define Tcl_GetUniChar \
(tclStubsPtr->tcl_GetUniChar) /* 381 */
-#endif
-#ifndef Tcl_GetUnicode
#define Tcl_GetUnicode \
(tclStubsPtr->tcl_GetUnicode) /* 382 */
-#endif
-#ifndef Tcl_GetRange
#define Tcl_GetRange \
(tclStubsPtr->tcl_GetRange) /* 383 */
-#endif
-#ifndef Tcl_AppendUnicodeToObj
#define Tcl_AppendUnicodeToObj \
(tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */
-#endif
-#ifndef Tcl_RegExpMatchObj
#define Tcl_RegExpMatchObj \
(tclStubsPtr->tcl_RegExpMatchObj) /* 385 */
-#endif
-#ifndef Tcl_SetNotifier
#define Tcl_SetNotifier \
(tclStubsPtr->tcl_SetNotifier) /* 386 */
-#endif
-#ifndef Tcl_GetAllocMutex
#define Tcl_GetAllocMutex \
(tclStubsPtr->tcl_GetAllocMutex) /* 387 */
-#endif
-#ifndef Tcl_GetChannelNames
#define Tcl_GetChannelNames \
(tclStubsPtr->tcl_GetChannelNames) /* 388 */
-#endif
-#ifndef Tcl_GetChannelNamesEx
#define Tcl_GetChannelNamesEx \
(tclStubsPtr->tcl_GetChannelNamesEx) /* 389 */
-#endif
-#ifndef Tcl_ProcObjCmd
#define Tcl_ProcObjCmd \
(tclStubsPtr->tcl_ProcObjCmd) /* 390 */
-#endif
-#ifndef Tcl_ConditionFinalize
#define Tcl_ConditionFinalize \
(tclStubsPtr->tcl_ConditionFinalize) /* 391 */
-#endif
-#ifndef Tcl_MutexFinalize
#define Tcl_MutexFinalize \
(tclStubsPtr->tcl_MutexFinalize) /* 392 */
-#endif
-#ifndef Tcl_CreateThread
#define Tcl_CreateThread \
(tclStubsPtr->tcl_CreateThread) /* 393 */
-#endif
-#ifndef Tcl_ReadRaw
#define Tcl_ReadRaw \
(tclStubsPtr->tcl_ReadRaw) /* 394 */
-#endif
-#ifndef Tcl_WriteRaw
#define Tcl_WriteRaw \
(tclStubsPtr->tcl_WriteRaw) /* 395 */
-#endif
-#ifndef Tcl_GetTopChannel
#define Tcl_GetTopChannel \
(tclStubsPtr->tcl_GetTopChannel) /* 396 */
-#endif
-#ifndef Tcl_ChannelBuffered
#define Tcl_ChannelBuffered \
(tclStubsPtr->tcl_ChannelBuffered) /* 397 */
-#endif
-#ifndef Tcl_ChannelName
#define Tcl_ChannelName \
(tclStubsPtr->tcl_ChannelName) /* 398 */
-#endif
-#ifndef Tcl_ChannelVersion
#define Tcl_ChannelVersion \
(tclStubsPtr->tcl_ChannelVersion) /* 399 */
-#endif
-#ifndef Tcl_ChannelBlockModeProc
#define Tcl_ChannelBlockModeProc \
(tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */
-#endif
-#ifndef Tcl_ChannelCloseProc
#define Tcl_ChannelCloseProc \
(tclStubsPtr->tcl_ChannelCloseProc) /* 401 */
-#endif
-#ifndef Tcl_ChannelClose2Proc
#define Tcl_ChannelClose2Proc \
(tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */
-#endif
-#ifndef Tcl_ChannelInputProc
#define Tcl_ChannelInputProc \
(tclStubsPtr->tcl_ChannelInputProc) /* 403 */
-#endif
-#ifndef Tcl_ChannelOutputProc
#define Tcl_ChannelOutputProc \
(tclStubsPtr->tcl_ChannelOutputProc) /* 404 */
-#endif
-#ifndef Tcl_ChannelSeekProc
#define Tcl_ChannelSeekProc \
(tclStubsPtr->tcl_ChannelSeekProc) /* 405 */
-#endif
-#ifndef Tcl_ChannelSetOptionProc
#define Tcl_ChannelSetOptionProc \
(tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */
-#endif
-#ifndef Tcl_ChannelGetOptionProc
#define Tcl_ChannelGetOptionProc \
(tclStubsPtr->tcl_ChannelGetOptionProc) /* 407 */
-#endif
-#ifndef Tcl_ChannelWatchProc
#define Tcl_ChannelWatchProc \
(tclStubsPtr->tcl_ChannelWatchProc) /* 408 */
-#endif
-#ifndef Tcl_ChannelGetHandleProc
#define Tcl_ChannelGetHandleProc \
(tclStubsPtr->tcl_ChannelGetHandleProc) /* 409 */
-#endif
-#ifndef Tcl_ChannelFlushProc
#define Tcl_ChannelFlushProc \
(tclStubsPtr->tcl_ChannelFlushProc) /* 410 */
-#endif
-#ifndef Tcl_ChannelHandlerProc
#define Tcl_ChannelHandlerProc \
(tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */
-#endif
-#ifndef Tcl_JoinThread
#define Tcl_JoinThread \
(tclStubsPtr->tcl_JoinThread) /* 412 */
-#endif
-#ifndef Tcl_IsChannelShared
#define Tcl_IsChannelShared \
(tclStubsPtr->tcl_IsChannelShared) /* 413 */
-#endif
-#ifndef Tcl_IsChannelRegistered
#define Tcl_IsChannelRegistered \
(tclStubsPtr->tcl_IsChannelRegistered) /* 414 */
-#endif
-#ifndef Tcl_CutChannel
#define Tcl_CutChannel \
(tclStubsPtr->tcl_CutChannel) /* 415 */
-#endif
-#ifndef Tcl_SpliceChannel
#define Tcl_SpliceChannel \
(tclStubsPtr->tcl_SpliceChannel) /* 416 */
-#endif
-#ifndef Tcl_ClearChannelHandlers
#define Tcl_ClearChannelHandlers \
(tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */
-#endif
-#ifndef Tcl_IsChannelExisting
#define Tcl_IsChannelExisting \
(tclStubsPtr->tcl_IsChannelExisting) /* 418 */
-#endif
-#ifndef Tcl_UniCharNcasecmp
#define Tcl_UniCharNcasecmp \
(tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */
-#endif
-#ifndef Tcl_UniCharCaseMatch
#define Tcl_UniCharCaseMatch \
(tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */
-#endif
-#ifndef Tcl_FindHashEntry
#define Tcl_FindHashEntry \
(tclStubsPtr->tcl_FindHashEntry) /* 421 */
-#endif
-#ifndef Tcl_CreateHashEntry
#define Tcl_CreateHashEntry \
(tclStubsPtr->tcl_CreateHashEntry) /* 422 */
-#endif
-#ifndef Tcl_InitCustomHashTable
#define Tcl_InitCustomHashTable \
(tclStubsPtr->tcl_InitCustomHashTable) /* 423 */
-#endif
-#ifndef Tcl_InitObjHashTable
#define Tcl_InitObjHashTable \
(tclStubsPtr->tcl_InitObjHashTable) /* 424 */
-#endif
-#ifndef Tcl_CommandTraceInfo
#define Tcl_CommandTraceInfo \
(tclStubsPtr->tcl_CommandTraceInfo) /* 425 */
-#endif
-#ifndef Tcl_TraceCommand
#define Tcl_TraceCommand \
(tclStubsPtr->tcl_TraceCommand) /* 426 */
-#endif
-#ifndef Tcl_UntraceCommand
#define Tcl_UntraceCommand \
(tclStubsPtr->tcl_UntraceCommand) /* 427 */
-#endif
-#ifndef Tcl_AttemptAlloc
#define Tcl_AttemptAlloc \
(tclStubsPtr->tcl_AttemptAlloc) /* 428 */
-#endif
-#ifndef Tcl_AttemptDbCkalloc
#define Tcl_AttemptDbCkalloc \
(tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */
-#endif
-#ifndef Tcl_AttemptRealloc
#define Tcl_AttemptRealloc \
(tclStubsPtr->tcl_AttemptRealloc) /* 430 */
-#endif
-#ifndef Tcl_AttemptDbCkrealloc
#define Tcl_AttemptDbCkrealloc \
(tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */
-#endif
-#ifndef Tcl_AttemptSetObjLength
#define Tcl_AttemptSetObjLength \
(tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */
-#endif
-#ifndef Tcl_GetChannelThread
#define Tcl_GetChannelThread \
(tclStubsPtr->tcl_GetChannelThread) /* 433 */
-#endif
-#ifndef Tcl_GetUnicodeFromObj
#define Tcl_GetUnicodeFromObj \
(tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
-#endif
-#ifndef Tcl_GetMathFuncInfo
#define Tcl_GetMathFuncInfo \
(tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */
-#endif
-#ifndef Tcl_ListMathFuncs
#define Tcl_ListMathFuncs \
(tclStubsPtr->tcl_ListMathFuncs) /* 436 */
-#endif
-#ifndef Tcl_SubstObj
#define Tcl_SubstObj \
(tclStubsPtr->tcl_SubstObj) /* 437 */
-#endif
-#ifndef Tcl_DetachChannel
#define Tcl_DetachChannel \
(tclStubsPtr->tcl_DetachChannel) /* 438 */
-#endif
-#ifndef Tcl_IsStandardChannel
#define Tcl_IsStandardChannel \
(tclStubsPtr->tcl_IsStandardChannel) /* 439 */
-#endif
-#ifndef Tcl_FSCopyFile
#define Tcl_FSCopyFile \
(tclStubsPtr->tcl_FSCopyFile) /* 440 */
-#endif
-#ifndef Tcl_FSCopyDirectory
#define Tcl_FSCopyDirectory \
(tclStubsPtr->tcl_FSCopyDirectory) /* 441 */
-#endif
-#ifndef Tcl_FSCreateDirectory
#define Tcl_FSCreateDirectory \
(tclStubsPtr->tcl_FSCreateDirectory) /* 442 */
-#endif
-#ifndef Tcl_FSDeleteFile
#define Tcl_FSDeleteFile \
(tclStubsPtr->tcl_FSDeleteFile) /* 443 */
-#endif
-#ifndef Tcl_FSLoadFile
#define Tcl_FSLoadFile \
(tclStubsPtr->tcl_FSLoadFile) /* 444 */
-#endif
-#ifndef Tcl_FSMatchInDirectory
#define Tcl_FSMatchInDirectory \
(tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */
-#endif
-#ifndef Tcl_FSLink
#define Tcl_FSLink \
(tclStubsPtr->tcl_FSLink) /* 446 */
-#endif
-#ifndef Tcl_FSRemoveDirectory
#define Tcl_FSRemoveDirectory \
(tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */
-#endif
-#ifndef Tcl_FSRenameFile
#define Tcl_FSRenameFile \
(tclStubsPtr->tcl_FSRenameFile) /* 448 */
-#endif
-#ifndef Tcl_FSLstat
#define Tcl_FSLstat \
(tclStubsPtr->tcl_FSLstat) /* 449 */
-#endif
-#ifndef Tcl_FSUtime
#define Tcl_FSUtime \
(tclStubsPtr->tcl_FSUtime) /* 450 */
-#endif
-#ifndef Tcl_FSFileAttrsGet
#define Tcl_FSFileAttrsGet \
(tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */
-#endif
-#ifndef Tcl_FSFileAttrsSet
#define Tcl_FSFileAttrsSet \
(tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */
-#endif
-#ifndef Tcl_FSFileAttrStrings
#define Tcl_FSFileAttrStrings \
(tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */
-#endif
-#ifndef Tcl_FSStat
#define Tcl_FSStat \
(tclStubsPtr->tcl_FSStat) /* 454 */
-#endif
-#ifndef Tcl_FSAccess
#define Tcl_FSAccess \
(tclStubsPtr->tcl_FSAccess) /* 455 */
-#endif
-#ifndef Tcl_FSOpenFileChannel
#define Tcl_FSOpenFileChannel \
(tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */
-#endif
-#ifndef Tcl_FSGetCwd
#define Tcl_FSGetCwd \
(tclStubsPtr->tcl_FSGetCwd) /* 457 */
-#endif
-#ifndef Tcl_FSChdir
#define Tcl_FSChdir \
(tclStubsPtr->tcl_FSChdir) /* 458 */
-#endif
-#ifndef Tcl_FSConvertToPathType
#define Tcl_FSConvertToPathType \
(tclStubsPtr->tcl_FSConvertToPathType) /* 459 */
-#endif
-#ifndef Tcl_FSJoinPath
#define Tcl_FSJoinPath \
(tclStubsPtr->tcl_FSJoinPath) /* 460 */
-#endif
-#ifndef Tcl_FSSplitPath
#define Tcl_FSSplitPath \
(tclStubsPtr->tcl_FSSplitPath) /* 461 */
-#endif
-#ifndef Tcl_FSEqualPaths
#define Tcl_FSEqualPaths \
(tclStubsPtr->tcl_FSEqualPaths) /* 462 */
-#endif
-#ifndef Tcl_FSGetNormalizedPath
#define Tcl_FSGetNormalizedPath \
(tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */
-#endif
-#ifndef Tcl_FSJoinToPath
#define Tcl_FSJoinToPath \
(tclStubsPtr->tcl_FSJoinToPath) /* 464 */
-#endif
-#ifndef Tcl_FSGetInternalRep
#define Tcl_FSGetInternalRep \
(tclStubsPtr->tcl_FSGetInternalRep) /* 465 */
-#endif
-#ifndef Tcl_FSGetTranslatedPath
#define Tcl_FSGetTranslatedPath \
(tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */
-#endif
-#ifndef Tcl_FSEvalFile
#define Tcl_FSEvalFile \
(tclStubsPtr->tcl_FSEvalFile) /* 467 */
-#endif
-#ifndef Tcl_FSNewNativePath
#define Tcl_FSNewNativePath \
(tclStubsPtr->tcl_FSNewNativePath) /* 468 */
-#endif
-#ifndef Tcl_FSGetNativePath
#define Tcl_FSGetNativePath \
(tclStubsPtr->tcl_FSGetNativePath) /* 469 */
-#endif
-#ifndef Tcl_FSFileSystemInfo
#define Tcl_FSFileSystemInfo \
(tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */
-#endif
-#ifndef Tcl_FSPathSeparator
#define Tcl_FSPathSeparator \
(tclStubsPtr->tcl_FSPathSeparator) /* 471 */
-#endif
-#ifndef Tcl_FSListVolumes
#define Tcl_FSListVolumes \
(tclStubsPtr->tcl_FSListVolumes) /* 472 */
-#endif
-#ifndef Tcl_FSRegister
#define Tcl_FSRegister \
(tclStubsPtr->tcl_FSRegister) /* 473 */
-#endif
-#ifndef Tcl_FSUnregister
#define Tcl_FSUnregister \
(tclStubsPtr->tcl_FSUnregister) /* 474 */
-#endif
-#ifndef Tcl_FSData
#define Tcl_FSData \
(tclStubsPtr->tcl_FSData) /* 475 */
-#endif
-#ifndef Tcl_FSGetTranslatedStringPath
#define Tcl_FSGetTranslatedStringPath \
(tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */
-#endif
-#ifndef Tcl_FSGetFileSystemForPath
#define Tcl_FSGetFileSystemForPath \
(tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */
-#endif
-#ifndef Tcl_FSGetPathType
#define Tcl_FSGetPathType \
(tclStubsPtr->tcl_FSGetPathType) /* 478 */
-#endif
-#ifndef Tcl_OutputBuffered
#define Tcl_OutputBuffered \
(tclStubsPtr->tcl_OutputBuffered) /* 479 */
-#endif
-#ifndef Tcl_FSMountsChanged
#define Tcl_FSMountsChanged \
(tclStubsPtr->tcl_FSMountsChanged) /* 480 */
-#endif
-#ifndef Tcl_EvalTokensStandard
#define Tcl_EvalTokensStandard \
(tclStubsPtr->tcl_EvalTokensStandard) /* 481 */
-#endif
-#ifndef Tcl_GetTime
#define Tcl_GetTime \
(tclStubsPtr->tcl_GetTime) /* 482 */
-#endif
-#ifndef Tcl_CreateObjTrace
#define Tcl_CreateObjTrace \
(tclStubsPtr->tcl_CreateObjTrace) /* 483 */
-#endif
-#ifndef Tcl_GetCommandInfoFromToken
#define Tcl_GetCommandInfoFromToken \
(tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
-#endif
-#ifndef Tcl_SetCommandInfoFromToken
#define Tcl_SetCommandInfoFromToken \
(tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
-#endif
-#ifndef Tcl_DbNewWideIntObj
#define Tcl_DbNewWideIntObj \
(tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */
-#endif
-#ifndef Tcl_GetWideIntFromObj
#define Tcl_GetWideIntFromObj \
(tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */
-#endif
-#ifndef Tcl_NewWideIntObj
#define Tcl_NewWideIntObj \
(tclStubsPtr->tcl_NewWideIntObj) /* 488 */
-#endif
-#ifndef Tcl_SetWideIntObj
#define Tcl_SetWideIntObj \
(tclStubsPtr->tcl_SetWideIntObj) /* 489 */
-#endif
-#ifndef Tcl_AllocStatBuf
#define Tcl_AllocStatBuf \
(tclStubsPtr->tcl_AllocStatBuf) /* 490 */
-#endif
-#ifndef Tcl_Seek
#define Tcl_Seek \
(tclStubsPtr->tcl_Seek) /* 491 */
-#endif
-#ifndef Tcl_Tell
#define Tcl_Tell \
(tclStubsPtr->tcl_Tell) /* 492 */
-#endif
-#ifndef Tcl_ChannelWideSeekProc
#define Tcl_ChannelWideSeekProc \
(tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */
-#endif
-#ifndef Tcl_DictObjPut
#define Tcl_DictObjPut \
(tclStubsPtr->tcl_DictObjPut) /* 494 */
-#endif
-#ifndef Tcl_DictObjGet
#define Tcl_DictObjGet \
(tclStubsPtr->tcl_DictObjGet) /* 495 */
-#endif
-#ifndef Tcl_DictObjRemove
#define Tcl_DictObjRemove \
(tclStubsPtr->tcl_DictObjRemove) /* 496 */
-#endif
-#ifndef Tcl_DictObjSize
#define Tcl_DictObjSize \
(tclStubsPtr->tcl_DictObjSize) /* 497 */
-#endif
-#ifndef Tcl_DictObjFirst
#define Tcl_DictObjFirst \
(tclStubsPtr->tcl_DictObjFirst) /* 498 */
-#endif
-#ifndef Tcl_DictObjNext
#define Tcl_DictObjNext \
(tclStubsPtr->tcl_DictObjNext) /* 499 */
-#endif
-#ifndef Tcl_DictObjDone
#define Tcl_DictObjDone \
(tclStubsPtr->tcl_DictObjDone) /* 500 */
-#endif
-#ifndef Tcl_DictObjPutKeyList
#define Tcl_DictObjPutKeyList \
(tclStubsPtr->tcl_DictObjPutKeyList) /* 501 */
-#endif
-#ifndef Tcl_DictObjRemoveKeyList
#define Tcl_DictObjRemoveKeyList \
(tclStubsPtr->tcl_DictObjRemoveKeyList) /* 502 */
-#endif
-#ifndef Tcl_NewDictObj
#define Tcl_NewDictObj \
(tclStubsPtr->tcl_NewDictObj) /* 503 */
-#endif
-#ifndef Tcl_DbNewDictObj
#define Tcl_DbNewDictObj \
(tclStubsPtr->tcl_DbNewDictObj) /* 504 */
-#endif
-#ifndef Tcl_RegisterConfig
#define Tcl_RegisterConfig \
(tclStubsPtr->tcl_RegisterConfig) /* 505 */
-#endif
-#ifndef Tcl_CreateNamespace
#define Tcl_CreateNamespace \
(tclStubsPtr->tcl_CreateNamespace) /* 506 */
-#endif
-#ifndef Tcl_DeleteNamespace
#define Tcl_DeleteNamespace \
(tclStubsPtr->tcl_DeleteNamespace) /* 507 */
-#endif
-#ifndef Tcl_AppendExportList
#define Tcl_AppendExportList \
(tclStubsPtr->tcl_AppendExportList) /* 508 */
-#endif
-#ifndef Tcl_Export
#define Tcl_Export \
(tclStubsPtr->tcl_Export) /* 509 */
-#endif
-#ifndef Tcl_Import
#define Tcl_Import \
(tclStubsPtr->tcl_Import) /* 510 */
-#endif
-#ifndef Tcl_ForgetImport
#define Tcl_ForgetImport \
(tclStubsPtr->tcl_ForgetImport) /* 511 */
-#endif
-#ifndef Tcl_GetCurrentNamespace
#define Tcl_GetCurrentNamespace \
(tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
-#endif
-#ifndef Tcl_GetGlobalNamespace
#define Tcl_GetGlobalNamespace \
(tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
-#endif
-#ifndef Tcl_FindNamespace
#define Tcl_FindNamespace \
(tclStubsPtr->tcl_FindNamespace) /* 514 */
-#endif
-#ifndef Tcl_FindCommand
#define Tcl_FindCommand \
(tclStubsPtr->tcl_FindCommand) /* 515 */
-#endif
-#ifndef Tcl_GetCommandFromObj
#define Tcl_GetCommandFromObj \
(tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
-#endif
-#ifndef Tcl_GetCommandFullName
#define Tcl_GetCommandFullName \
(tclStubsPtr->tcl_GetCommandFullName) /* 517 */
-#endif
-#ifndef Tcl_FSEvalFileEx
#define Tcl_FSEvalFileEx \
(tclStubsPtr->tcl_FSEvalFileEx) /* 518 */
-#endif
-#ifndef Tcl_SetExitProc
#define Tcl_SetExitProc \
(tclStubsPtr->tcl_SetExitProc) /* 519 */
-#endif
-#ifndef Tcl_LimitAddHandler
#define Tcl_LimitAddHandler \
(tclStubsPtr->tcl_LimitAddHandler) /* 520 */
-#endif
-#ifndef Tcl_LimitRemoveHandler
#define Tcl_LimitRemoveHandler \
(tclStubsPtr->tcl_LimitRemoveHandler) /* 521 */
-#endif
-#ifndef Tcl_LimitReady
#define Tcl_LimitReady \
(tclStubsPtr->tcl_LimitReady) /* 522 */
-#endif
-#ifndef Tcl_LimitCheck
#define Tcl_LimitCheck \
(tclStubsPtr->tcl_LimitCheck) /* 523 */
-#endif
-#ifndef Tcl_LimitExceeded
#define Tcl_LimitExceeded \
(tclStubsPtr->tcl_LimitExceeded) /* 524 */
-#endif
-#ifndef Tcl_LimitSetCommands
#define Tcl_LimitSetCommands \
(tclStubsPtr->tcl_LimitSetCommands) /* 525 */
-#endif
-#ifndef Tcl_LimitSetTime
#define Tcl_LimitSetTime \
(tclStubsPtr->tcl_LimitSetTime) /* 526 */
-#endif
-#ifndef Tcl_LimitSetGranularity
#define Tcl_LimitSetGranularity \
(tclStubsPtr->tcl_LimitSetGranularity) /* 527 */
-#endif
-#ifndef Tcl_LimitTypeEnabled
#define Tcl_LimitTypeEnabled \
(tclStubsPtr->tcl_LimitTypeEnabled) /* 528 */
-#endif
-#ifndef Tcl_LimitTypeExceeded
#define Tcl_LimitTypeExceeded \
(tclStubsPtr->tcl_LimitTypeExceeded) /* 529 */
-#endif
-#ifndef Tcl_LimitTypeSet
#define Tcl_LimitTypeSet \
(tclStubsPtr->tcl_LimitTypeSet) /* 530 */
-#endif
-#ifndef Tcl_LimitTypeReset
#define Tcl_LimitTypeReset \
(tclStubsPtr->tcl_LimitTypeReset) /* 531 */
-#endif
-#ifndef Tcl_LimitGetCommands
#define Tcl_LimitGetCommands \
(tclStubsPtr->tcl_LimitGetCommands) /* 532 */
-#endif
-#ifndef Tcl_LimitGetTime
#define Tcl_LimitGetTime \
(tclStubsPtr->tcl_LimitGetTime) /* 533 */
-#endif
-#ifndef Tcl_LimitGetGranularity
#define Tcl_LimitGetGranularity \
(tclStubsPtr->tcl_LimitGetGranularity) /* 534 */
-#endif
-#ifndef Tcl_SaveInterpState
#define Tcl_SaveInterpState \
(tclStubsPtr->tcl_SaveInterpState) /* 535 */
-#endif
-#ifndef Tcl_RestoreInterpState
#define Tcl_RestoreInterpState \
(tclStubsPtr->tcl_RestoreInterpState) /* 536 */
-#endif
-#ifndef Tcl_DiscardInterpState
#define Tcl_DiscardInterpState \
(tclStubsPtr->tcl_DiscardInterpState) /* 537 */
-#endif
-#ifndef Tcl_SetReturnOptions
#define Tcl_SetReturnOptions \
(tclStubsPtr->tcl_SetReturnOptions) /* 538 */
-#endif
-#ifndef Tcl_GetReturnOptions
#define Tcl_GetReturnOptions \
(tclStubsPtr->tcl_GetReturnOptions) /* 539 */
-#endif
-#ifndef Tcl_IsEnsemble
#define Tcl_IsEnsemble \
(tclStubsPtr->tcl_IsEnsemble) /* 540 */
-#endif
-#ifndef Tcl_CreateEnsemble
#define Tcl_CreateEnsemble \
(tclStubsPtr->tcl_CreateEnsemble) /* 541 */
-#endif
-#ifndef Tcl_FindEnsemble
#define Tcl_FindEnsemble \
(tclStubsPtr->tcl_FindEnsemble) /* 542 */
-#endif
-#ifndef Tcl_SetEnsembleSubcommandList
#define Tcl_SetEnsembleSubcommandList \
(tclStubsPtr->tcl_SetEnsembleSubcommandList) /* 543 */
-#endif
-#ifndef Tcl_SetEnsembleMappingDict
#define Tcl_SetEnsembleMappingDict \
(tclStubsPtr->tcl_SetEnsembleMappingDict) /* 544 */
-#endif
-#ifndef Tcl_SetEnsembleUnknownHandler
#define Tcl_SetEnsembleUnknownHandler \
(tclStubsPtr->tcl_SetEnsembleUnknownHandler) /* 545 */
-#endif
-#ifndef Tcl_SetEnsembleFlags
#define Tcl_SetEnsembleFlags \
(tclStubsPtr->tcl_SetEnsembleFlags) /* 546 */
-#endif
-#ifndef Tcl_GetEnsembleSubcommandList
#define Tcl_GetEnsembleSubcommandList \
(tclStubsPtr->tcl_GetEnsembleSubcommandList) /* 547 */
-#endif
-#ifndef Tcl_GetEnsembleMappingDict
#define Tcl_GetEnsembleMappingDict \
(tclStubsPtr->tcl_GetEnsembleMappingDict) /* 548 */
-#endif
-#ifndef Tcl_GetEnsembleUnknownHandler
#define Tcl_GetEnsembleUnknownHandler \
(tclStubsPtr->tcl_GetEnsembleUnknownHandler) /* 549 */
-#endif
-#ifndef Tcl_GetEnsembleFlags
#define Tcl_GetEnsembleFlags \
(tclStubsPtr->tcl_GetEnsembleFlags) /* 550 */
-#endif
-#ifndef Tcl_GetEnsembleNamespace
#define Tcl_GetEnsembleNamespace \
(tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */
-#endif
-#ifndef Tcl_SetTimeProc
#define Tcl_SetTimeProc \
(tclStubsPtr->tcl_SetTimeProc) /* 552 */
-#endif
-#ifndef Tcl_QueryTimeProc
#define Tcl_QueryTimeProc \
(tclStubsPtr->tcl_QueryTimeProc) /* 553 */
-#endif
-#ifndef Tcl_ChannelThreadActionProc
#define Tcl_ChannelThreadActionProc \
(tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */
-#endif
-#ifndef Tcl_NewBignumObj
#define Tcl_NewBignumObj \
(tclStubsPtr->tcl_NewBignumObj) /* 555 */
-#endif
-#ifndef Tcl_DbNewBignumObj
#define Tcl_DbNewBignumObj \
(tclStubsPtr->tcl_DbNewBignumObj) /* 556 */
-#endif
-#ifndef Tcl_SetBignumObj
#define Tcl_SetBignumObj \
(tclStubsPtr->tcl_SetBignumObj) /* 557 */
-#endif
-#ifndef Tcl_GetBignumFromObj
#define Tcl_GetBignumFromObj \
(tclStubsPtr->tcl_GetBignumFromObj) /* 558 */
-#endif
-#ifndef Tcl_TakeBignumFromObj
#define Tcl_TakeBignumFromObj \
(tclStubsPtr->tcl_TakeBignumFromObj) /* 559 */
-#endif
-#ifndef Tcl_TruncateChannel
#define Tcl_TruncateChannel \
(tclStubsPtr->tcl_TruncateChannel) /* 560 */
-#endif
-#ifndef Tcl_ChannelTruncateProc
#define Tcl_ChannelTruncateProc \
(tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */
-#endif
-#ifndef Tcl_SetChannelErrorInterp
#define Tcl_SetChannelErrorInterp \
(tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */
-#endif
-#ifndef Tcl_GetChannelErrorInterp
#define Tcl_GetChannelErrorInterp \
(tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */
-#endif
-#ifndef Tcl_SetChannelError
#define Tcl_SetChannelError \
(tclStubsPtr->tcl_SetChannelError) /* 564 */
-#endif
-#ifndef Tcl_GetChannelError
#define Tcl_GetChannelError \
(tclStubsPtr->tcl_GetChannelError) /* 565 */
-#endif
-#ifndef Tcl_InitBignumFromDouble
#define Tcl_InitBignumFromDouble \
(tclStubsPtr->tcl_InitBignumFromDouble) /* 566 */
-#endif
-#ifndef Tcl_GetNamespaceUnknownHandler
#define Tcl_GetNamespaceUnknownHandler \
(tclStubsPtr->tcl_GetNamespaceUnknownHandler) /* 567 */
-#endif
-#ifndef Tcl_SetNamespaceUnknownHandler
#define Tcl_SetNamespaceUnknownHandler \
(tclStubsPtr->tcl_SetNamespaceUnknownHandler) /* 568 */
-#endif
-#ifndef Tcl_GetEncodingFromObj
#define Tcl_GetEncodingFromObj \
(tclStubsPtr->tcl_GetEncodingFromObj) /* 569 */
-#endif
-#ifndef Tcl_GetEncodingSearchPath
#define Tcl_GetEncodingSearchPath \
(tclStubsPtr->tcl_GetEncodingSearchPath) /* 570 */
-#endif
-#ifndef Tcl_SetEncodingSearchPath
#define Tcl_SetEncodingSearchPath \
(tclStubsPtr->tcl_SetEncodingSearchPath) /* 571 */
-#endif
-#ifndef Tcl_GetEncodingNameFromEnvironment
#define Tcl_GetEncodingNameFromEnvironment \
(tclStubsPtr->tcl_GetEncodingNameFromEnvironment) /* 572 */
-#endif
-#ifndef Tcl_PkgRequireProc
#define Tcl_PkgRequireProc \
(tclStubsPtr->tcl_PkgRequireProc) /* 573 */
-#endif
-#ifndef Tcl_AppendObjToErrorInfo
#define Tcl_AppendObjToErrorInfo \
(tclStubsPtr->tcl_AppendObjToErrorInfo) /* 574 */
-#endif
-#ifndef Tcl_AppendLimitedToObj
#define Tcl_AppendLimitedToObj \
(tclStubsPtr->tcl_AppendLimitedToObj) /* 575 */
-#endif
-#ifndef Tcl_Format
#define Tcl_Format \
(tclStubsPtr->tcl_Format) /* 576 */
-#endif
-#ifndef Tcl_AppendFormatToObj
#define Tcl_AppendFormatToObj \
(tclStubsPtr->tcl_AppendFormatToObj) /* 577 */
-#endif
-#ifndef Tcl_ObjPrintf
#define Tcl_ObjPrintf \
(tclStubsPtr->tcl_ObjPrintf) /* 578 */
-#endif
-#ifndef Tcl_AppendPrintfToObj
#define Tcl_AppendPrintfToObj \
(tclStubsPtr->tcl_AppendPrintfToObj) /* 579 */
-#endif
+#define Tcl_CancelEval \
+ (tclStubsPtr->tcl_CancelEval) /* 580 */
+#define Tcl_Canceled \
+ (tclStubsPtr->tcl_Canceled) /* 581 */
+#define Tcl_CreatePipe \
+ (tclStubsPtr->tcl_CreatePipe) /* 582 */
+#define Tcl_NRCreateCommand \
+ (tclStubsPtr->tcl_NRCreateCommand) /* 583 */
+#define Tcl_NREvalObj \
+ (tclStubsPtr->tcl_NREvalObj) /* 584 */
+#define Tcl_NREvalObjv \
+ (tclStubsPtr->tcl_NREvalObjv) /* 585 */
+#define Tcl_NRCmdSwap \
+ (tclStubsPtr->tcl_NRCmdSwap) /* 586 */
+#define Tcl_NRAddCallback \
+ (tclStubsPtr->tcl_NRAddCallback) /* 587 */
+#define Tcl_NRCallObjProc \
+ (tclStubsPtr->tcl_NRCallObjProc) /* 588 */
+#define Tcl_GetFSDeviceFromStat \
+ (tclStubsPtr->tcl_GetFSDeviceFromStat) /* 589 */
+#define Tcl_GetFSInodeFromStat \
+ (tclStubsPtr->tcl_GetFSInodeFromStat) /* 590 */
+#define Tcl_GetModeFromStat \
+ (tclStubsPtr->tcl_GetModeFromStat) /* 591 */
+#define Tcl_GetLinkCountFromStat \
+ (tclStubsPtr->tcl_GetLinkCountFromStat) /* 592 */
+#define Tcl_GetUserIdFromStat \
+ (tclStubsPtr->tcl_GetUserIdFromStat) /* 593 */
+#define Tcl_GetGroupIdFromStat \
+ (tclStubsPtr->tcl_GetGroupIdFromStat) /* 594 */
+#define Tcl_GetDeviceTypeFromStat \
+ (tclStubsPtr->tcl_GetDeviceTypeFromStat) /* 595 */
+#define Tcl_GetAccessTimeFromStat \
+ (tclStubsPtr->tcl_GetAccessTimeFromStat) /* 596 */
+#define Tcl_GetModificationTimeFromStat \
+ (tclStubsPtr->tcl_GetModificationTimeFromStat) /* 597 */
+#define Tcl_GetChangeTimeFromStat \
+ (tclStubsPtr->tcl_GetChangeTimeFromStat) /* 598 */
+#define Tcl_GetSizeFromStat \
+ (tclStubsPtr->tcl_GetSizeFromStat) /* 599 */
+#define Tcl_GetBlocksFromStat \
+ (tclStubsPtr->tcl_GetBlocksFromStat) /* 600 */
+#define Tcl_GetBlockSizeFromStat \
+ (tclStubsPtr->tcl_GetBlockSizeFromStat) /* 601 */
+#define Tcl_SetEnsembleParameterList \
+ (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */
+#define Tcl_GetEnsembleParameterList \
+ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */
+#define Tcl_ParseArgsObjv \
+ (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */
+#define Tcl_GetErrorLine \
+ (tclStubsPtr->tcl_GetErrorLine) /* 605 */
+#define Tcl_SetErrorLine \
+ (tclStubsPtr->tcl_SetErrorLine) /* 606 */
+#define Tcl_TransferResult \
+ (tclStubsPtr->tcl_TransferResult) /* 607 */
+#define Tcl_InterpActive \
+ (tclStubsPtr->tcl_InterpActive) /* 608 */
+#define Tcl_BackgroundException \
+ (tclStubsPtr->tcl_BackgroundException) /* 609 */
+#define Tcl_ZlibDeflate \
+ (tclStubsPtr->tcl_ZlibDeflate) /* 610 */
+#define Tcl_ZlibInflate \
+ (tclStubsPtr->tcl_ZlibInflate) /* 611 */
+#define Tcl_ZlibCRC32 \
+ (tclStubsPtr->tcl_ZlibCRC32) /* 612 */
+#define Tcl_ZlibAdler32 \
+ (tclStubsPtr->tcl_ZlibAdler32) /* 613 */
+#define Tcl_ZlibStreamInit \
+ (tclStubsPtr->tcl_ZlibStreamInit) /* 614 */
+#define Tcl_ZlibStreamGetCommandName \
+ (tclStubsPtr->tcl_ZlibStreamGetCommandName) /* 615 */
+#define Tcl_ZlibStreamEof \
+ (tclStubsPtr->tcl_ZlibStreamEof) /* 616 */
+#define Tcl_ZlibStreamChecksum \
+ (tclStubsPtr->tcl_ZlibStreamChecksum) /* 617 */
+#define Tcl_ZlibStreamPut \
+ (tclStubsPtr->tcl_ZlibStreamPut) /* 618 */
+#define Tcl_ZlibStreamGet \
+ (tclStubsPtr->tcl_ZlibStreamGet) /* 619 */
+#define Tcl_ZlibStreamClose \
+ (tclStubsPtr->tcl_ZlibStreamClose) /* 620 */
+#define Tcl_ZlibStreamReset \
+ (tclStubsPtr->tcl_ZlibStreamReset) /* 621 */
+#define Tcl_SetStartupScript \
+ (tclStubsPtr->tcl_SetStartupScript) /* 622 */
+#define Tcl_GetStartupScript \
+ (tclStubsPtr->tcl_GetStartupScript) /* 623 */
+#define Tcl_CloseEx \
+ (tclStubsPtr->tcl_CloseEx) /* 624 */
+#define Tcl_NRExprObj \
+ (tclStubsPtr->tcl_NRExprObj) /* 625 */
+#define Tcl_NRSubstObj \
+ (tclStubsPtr->tcl_NRSubstObj) /* 626 */
+#define Tcl_LoadFile \
+ (tclStubsPtr->tcl_LoadFile) /* 627 */
+#define Tcl_FindSymbol \
+ (tclStubsPtr->tcl_FindSymbol) /* 628 */
+#define Tcl_FSUnloadFile \
+ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */
-#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
+#if defined(USE_TCL_STUBS)
+# undef Tcl_CreateInterp
+# undef Tcl_FindExecutable
+# undef Tcl_GetStringResult
+# undef Tcl_Init
+# undef Tcl_SetPanicProc
+# undef Tcl_SetVar
+# undef Tcl_StaticPackage
+# undef TclFSGetNativePath
+# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
+# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
+# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
+# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc))
+# define Tcl_SetVar(interp, varName, newValue, flags) \
+ (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags))
+#endif
+
+#if defined(_WIN32) && defined(UNICODE)
+# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
+# define Tcl_MainEx Tcl_MainExW
+ EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
+ Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
+# define Tcl_Main(argc, argv, proc) Tcl_MainExW(argc, argv, proc, \
+ (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+#endif
+
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLDECLS */
-
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 912e7a9..508c2af 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -4,7 +4,7 @@
* This file contains functions that implement the Tcl dict object type
* and its accessor command.
*
- * Copyright (c) 2002 by Donal K. Fellows.
+ * Copyright (c) 2002-2010 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,8 +31,6 @@ static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
-static int DictForCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
static int DictGetCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp,
@@ -72,32 +70,41 @@ static inline void DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
Tcl_Obj *keyPtr, int *newPtr);
static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
+static int FinalizeDictUpdate(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeDictWith(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictForLoopCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
+
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
- {"append", DictAppendCmd, TclCompileDictAppendCmd },
- {"create", DictCreateCmd, NULL },
- {"exists", DictExistsCmd, NULL },
- {"filter", DictFilterCmd, NULL },
- {"for", DictForCmd, TclCompileDictForCmd },
- {"get", DictGetCmd, TclCompileDictGetCmd },
- {"incr", DictIncrCmd, TclCompileDictIncrCmd },
- {"info", DictInfoCmd, NULL },
- {"keys", DictKeysCmd, NULL },
- {"lappend", DictLappendCmd, TclCompileDictLappendCmd },
- {"merge", DictMergeCmd, NULL },
- {"remove", DictRemoveCmd, NULL },
- {"replace", DictReplaceCmd, NULL },
- {"set", DictSetCmd, TclCompileDictSetCmd },
- {"size", DictSizeCmd, NULL },
- {"unset", DictUnsetCmd, NULL },
- {"update", DictUpdateCmd, TclCompileDictUpdateCmd },
- {"values", DictValuesCmd, NULL },
- {"with", DictWithCmd, NULL },
- {NULL}
+ {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
+ {"create", DictCreateCmd, NULL, NULL, NULL, 0 },
+ {"exists", DictExistsCmd, 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 },
+ {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
+ {"merge", DictMergeCmd, NULL, NULL, NULL, 0 },
+ {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 },
+ {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
+ {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
+ {"size", DictSizeCmd, NULL, NULL, NULL, 0 },
+ {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 },
+ {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
+ {"values", DictValuesCmd, NULL, NULL, NULL, 0 },
+ {"with", DictWithCmd, NULL, NULL, NULL, 0 },
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -148,10 +155,10 @@ typedef struct Dict {
* functions that can be invoked by generic object code.
*/
-Tcl_ObjType tclDictType = {
+const Tcl_ObjType tclDictType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
- DupDictInternalRep, /* dupIntRepProc */
+ DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny /* setFromAnyProc */
};
@@ -166,7 +173,7 @@ Tcl_ObjType tclDictType = {
* *this* file. Everything else should use the dict iterator API.
*/
-static Tcl_HashKeyType chainHashType = {
+static const Tcl_HashKeyType chainHashType = {
TCL_HASH_KEY_TYPE_VERSION,
0,
TclHashObjKey,
@@ -203,8 +210,8 @@ AllocChainEntry(
Tcl_Obj *objPtr = keyPtr;
ChainEntry *cPtr;
- cPtr = (ChainEntry *) ckalloc(sizeof(ChainEntry));
- cPtr->entry.key.oneWordValue = (char *) objPtr;
+ cPtr = ckalloc(sizeof(ChainEntry));
+ cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
cPtr->entry.clientData = NULL;
cPtr->prevPtr = cPtr->nextPtr = NULL;
@@ -250,7 +257,7 @@ CreateChainEntry(
int *newPtr)
{
ChainEntry *cPtr = (ChainEntry *)
- Tcl_CreateHashEntry(&dict->table, (char *) keyPtr, newPtr);
+ Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr);
/*
* If this is a new entry in the hash table, stitch it into the chain.
@@ -278,7 +285,7 @@ DeleteChainEntry(
Tcl_Obj *keyPtr)
{
ChainEntry *cPtr = (ChainEntry *)
- Tcl_FindHashEntry(&dict->table, (char *) keyPtr);
+ Tcl_FindHashEntry(&dict->table, keyPtr);
if (cPtr == NULL) {
return 0;
@@ -334,7 +341,7 @@ DupDictInternalRep(
Tcl_Obj *copyPtr)
{
Dict *oldDict = srcPtr->internalRep.otherValuePtr;
- Dict *newDict = (Dict *) ckalloc(sizeof(Dict));
+ Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
/*
@@ -343,7 +350,7 @@ DupDictInternalRep(
InitChainTable(newDict);
for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
- void *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
+ Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
int n;
Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
@@ -352,7 +359,7 @@ DupDictInternalRep(
* Fill in the contents.
*/
- Tcl_SetHashValue(hPtr, (ClientData) valuePtr);
+ Tcl_SetHashValue(hPtr, valuePtr);
Tcl_IncrRefCount(valuePtr);
}
@@ -396,7 +403,7 @@ FreeDictInternalRep(
{
Dict *dict = dictPtr->internalRep.otherValuePtr;
- --dict->refcount;
+ dict->refcount--;
if (dict->refcount <= 0) {
DeleteDict(dict);
}
@@ -430,7 +437,7 @@ DeleteDict(
Dict *dict)
{
DeleteChainTable(dict);
- ckfree((char *) dict);
+ ckfree(dict);
}
/*
@@ -465,7 +472,8 @@ UpdateStringOfDict(
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int numElems, i, length;
- char *elem, *dst;
+ const char *elem;
+ char *dst;
/*
* This field is the most useful one in the whole hash structure, and it
@@ -481,7 +489,7 @@ UpdateStringOfDict(
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
+ flagPtr = ckalloc(numElems * sizeof(int));
}
dictPtr->length = 1;
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
@@ -490,7 +498,7 @@ UpdateStringOfDict(
* elements already.
*/
- keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
dictPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i]) + 1;
@@ -505,10 +513,10 @@ UpdateStringOfDict(
* Pass 2: copy into string rep buffer.
*/
- dictPtr->bytes = ckalloc((unsigned) dictPtr->length);
+ dictPtr->bytes = ckalloc(dictPtr->length);
dst = dictPtr->bytes;
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
- keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
dst += Tcl_ConvertCountedElement(elem, length, dst,
flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
@@ -521,7 +529,7 @@ UpdateStringOfDict(
*(dst++) = ' ';
}
if (flagPtr != localFlags) {
- ckfree((char *) flagPtr);
+ ckfree(flagPtr);
}
if (dst == dictPtr->bytes) {
*dst = 0;
@@ -556,10 +564,11 @@ SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
- char *string, *s;
+ const char *string;
+ char *s;
const char *elemStart, *nextElem;
int lenRemain, length, elemSize, hasBrace, result, isNew;
- char *limit; /* Points just after string's last byte. */
+ const char *limit; /* Points just after string's last byte. */
register const char *p;
register Tcl_Obj *keyPtr, *valuePtr;
Dict *dict;
@@ -582,6 +591,7 @@ SetDictFromAny(
if (interp != NULL) {
Tcl_SetResult(interp, "missing value to go with key",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
return TCL_ERROR;
}
@@ -590,7 +600,7 @@ SetDictFromAny(
* Build the hash of key/value pairs.
*/
- dict = (Dict *) ckalloc(sizeof(Dict));
+ dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
for (i=0 ; i<objc ; i+=2) {
/*
@@ -634,7 +644,7 @@ SetDictFromAny(
* values.
*/
- dict = (Dict *) ckalloc(sizeof(Dict));
+ dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
for (p = string, lenRemain = length;
lenRemain > 0;
@@ -642,6 +652,9 @@ SetDictFromAny(
result = TclFindElement(interp, p, lenRemain,
&elemStart, &nextElem, &elemSize, &hasBrace);
if (result != TCL_OK) {
+ if (interp != NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
+ }
goto errorExit;
}
if (elemStart >= limit) {
@@ -653,7 +666,7 @@ SetDictFromAny(
* "elemSize" bytes starting at "elemStart".
*/
- s = ckalloc((unsigned) elemSize + 1);
+ s = ckalloc(elemSize + 1);
if (hasBrace) {
memcpy(s, elemStart, (size_t) elemSize);
s[elemSize] = 0;
@@ -662,8 +675,8 @@ SetDictFromAny(
}
TclNewObj(keyPtr);
- keyPtr->bytes = s;
- keyPtr->length = elemSize;
+ keyPtr->bytes = s;
+ keyPtr->length = elemSize;
p = nextElem;
lenRemain = (limit - nextElem);
@@ -674,6 +687,9 @@ SetDictFromAny(
result = TclFindElement(interp, p, lenRemain,
&elemStart, &nextElem, &elemSize, &hasBrace);
if (result != TCL_OK) {
+ if (interp != NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
+ }
TclDecrRefCount(keyPtr);
goto errorExit;
}
@@ -686,17 +702,17 @@ SetDictFromAny(
* "elemSize" bytes starting at "elemStart".
*/
- s = ckalloc((unsigned) elemSize + 1);
+ s = ckalloc(elemSize + 1);
if (hasBrace) {
- memcpy((void *) s, (void *) elemStart, (size_t) elemSize);
+ memcpy(s, elemStart, (size_t) elemSize);
s[elemSize] = 0;
} else {
elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
}
TclNewObj(valuePtr);
- valuePtr->bytes = s;
- valuePtr->length = elemSize;
+ valuePtr->bytes = s;
+ valuePtr->length = elemSize;
/*
* Store key and value in the hash table we're building.
@@ -710,7 +726,7 @@ SetDictFromAny(
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, valuePtr);
- Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
+ Tcl_IncrRefCount(valuePtr); /* Since hash now holds ref to it. */
}
installHash:
@@ -731,13 +747,14 @@ SetDictFromAny(
missingKey:
if (interp != NULL) {
Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
TclDecrRefCount(keyPtr);
result = TCL_ERROR;
errorExit:
DeleteChainTable(dict);
- ckfree((char *) dict);
+ ckfree(dict);
return result;
}
@@ -795,7 +812,7 @@ TclTraceDictPath(
}
for (i=0 ; i<keyc ; i++) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[i]);
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
Tcl_Obj *tmpObj;
if (hPtr == NULL) {
@@ -838,7 +855,7 @@ TclTraceDictPath(
TclDecrRefCount(tmpObj);
tmpObj = Tcl_DuplicateObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
- Tcl_SetHashValue(hPtr, (ClientData) tmpObj);
+ Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
newDict = tmpObj->internalRep.otherValuePtr;
}
@@ -985,7 +1002,7 @@ Tcl_DictObjGet(
}
dict = dictPtr->internalRep.otherValuePtr;
- hPtr = Tcl_FindHashEntry(&dict->table, (char *) keyPtr);
+ hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
@@ -1142,8 +1159,7 @@ Tcl_DictObjFirst(
searchPtr->next = cPtr->nextPtr;
dict->refcount++;
if (keyPtrPtr != NULL) {
- *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table,
- &cPtr->entry);
+ *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
*valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
@@ -1219,7 +1235,7 @@ Tcl_DictObjNext(
searchPtr->next = cPtr->nextPtr;
*donePtr = 0;
if (keyPtrPtr != NULL) {
- *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(
+ *keyPtrPtr = Tcl_GetHashKey(
&((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
@@ -1403,7 +1419,7 @@ Tcl_NewDictObj(void)
TclNewObj(dictPtr);
Tcl_InvalidateStringRep(dictPtr);
- dict = (Dict *) ckalloc(sizeof(Dict));
+ dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
@@ -1452,7 +1468,7 @@ Tcl_DbNewDictObj(
TclDbNewObj(dictPtr, file, line);
Tcl_InvalidateStringRep(dictPtr);
- dict = (Dict *) ckalloc(sizeof(Dict));
+ dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
@@ -1546,7 +1562,7 @@ DictGetCmd(
int result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key key ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
return TCL_ERROR;
}
@@ -1557,7 +1573,7 @@ DictGetCmd(
*/
if (objc == 2) {
- Tcl_Obj *keyPtr, *listPtr;
+ Tcl_Obj *keyPtr = NULL, *listPtr;
Tcl_DictSearch search;
int done;
@@ -1602,6 +1618,8 @@ DictGetCmd(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]),
"\" not known in dictionary", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(objv[objc-1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
@@ -1737,7 +1755,7 @@ DictMergeCmd(
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *targetObj, *keyObj, *valueObj;
+ Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
int allocatedDict = 0;
int i, done;
Tcl_DictSearch search;
@@ -1827,7 +1845,7 @@ DictKeysCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *listPtr;
- char *pattern = NULL;
+ const char *pattern = NULL;
if (objc!=2 && objc!=3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
@@ -1861,8 +1879,8 @@ DictKeysCmd(
}
} else {
Tcl_DictSearch search;
- Tcl_Obj *keyPtr;
- int done;
+ Tcl_Obj *keyPtr = NULL;
+ int done = 0;
/*
* At this point, we know we have a dictionary (or at least something
@@ -1909,10 +1927,10 @@ DictValuesCmd(
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *valuePtr, *listPtr;
+ Tcl_Obj *valuePtr = NULL, *listPtr;
Tcl_DictSearch search;
int done;
- char *pattern;
+ const char *pattern;
if (objc!=2 && objc!=3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
@@ -2074,11 +2092,7 @@ DictInfoCmd(
}
dict = dictPtr->internalRep.otherValuePtr;
- /*
- * This next cast is actually OK.
- */
-
- Tcl_SetResult(interp, (char *) Tcl_HashStats(&dict->table), TCL_DYNAMIC);
+ Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC);
return TCL_OK;
}
@@ -2365,7 +2379,7 @@ DictAppendCmd(
/*
*----------------------------------------------------------------------
*
- * DictForCmd --
+ * DictForNRCmd --
*
* This function implements the "dict for" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
@@ -2381,7 +2395,7 @@ DictAppendCmd(
*/
static int
-DictForCmd(
+DictForNRCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
@@ -2390,8 +2404,8 @@ DictForCmd(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
- Tcl_DictSearch search;
- int varc, done, result;
+ Tcl_DictSearch *searchPtr;
+ int varc, done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2399,6 +2413,10 @@ DictForCmd(
return TCL_ERROR;
}
+ /*
+ * Parse arguments.
+ */
+
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2407,14 +2425,20 @@ DictForCmd(
TCL_STATIC);
return TCL_ERROR;
}
- keyVarObj = varv[0];
- valueVarObj = varv[1];
- scriptObj = objv[3];
-
- if (Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj,
+ searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
+ if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
+ TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
+ if (done) {
+ TclStackFree(interp, searchPtr);
+ return TCL_OK;
+ }
+ TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ keyVarObj = varv[0];
+ valueVarObj = varv[1];
+ scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
@@ -2426,64 +2450,119 @@ DictForCmd(
Tcl_IncrRefCount(valueVarObj);
Tcl_IncrRefCount(scriptObj);
- result = TCL_OK;
- while (!done) {
- /*
- * Stop the value from getting hit in any way by any traces on the key
- * variable.
- */
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
- Tcl_IncrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set key variable: \"",
- TclGetString(keyVarObj), "\"", NULL);
- TclDecrRefCount(valueObj);
- result = TCL_ERROR;
- break;
- }
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set value variable: \"",
- TclGetString(valueVarObj), "\"", NULL);
- result = TCL_ERROR;
- break;
- }
+ goto error;
+ }
+ TclDecrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ goto error;
+ }
- /*
- * TIP #280. Make invoking context available to loop body.
- */
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ valueVarObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything on error.
+ */
+
+ error:
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ Tcl_DictObjDone(searchPtr);
+ TclStackFree(interp, searchPtr);
+ return TCL_ERROR;
+}
+
+static int
+DictForLoopCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_DictSearch *searchPtr = data[0];
+ Tcl_Obj *keyVarObj = data[1];
+ Tcl_Obj *valueVarObj = data[2];
+ Tcl_Obj *scriptObj = data[3];
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
- result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
- if (result == TCL_CONTINUE) {
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
result = TCL_OK;
- } else if (result != TCL_OK) {
- if (result == TCL_BREAK) {
- result = TCL_OK;
- } else if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"dict for\" body line %d)",
- interp->errorLine));
- }
- break;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"dict for\" body line %d)",
+ Tcl_GetErrorLine(interp)));
}
+ goto done;
+ }
+
+ /*
+ * Get the next mapping from the dictionary.
+ */
+
+ Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done);
+ if (done) {
+ Tcl_ResetResult(interp);
+ goto done;
+ }
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
- Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclDecrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto done;
}
/*
- * Stop holding a reference to these objects.
+ * Run the script.
*/
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ valueVarObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ done:
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
-
- Tcl_DictObjDone(&search);
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- }
+ Tcl_DictObjDone(searchPtr);
+ TclStackFree(interp, searchPtr);
return result;
}
@@ -2632,20 +2711,20 @@ DictFilterCmd(
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
- static const char *filters[] = {
+ static const char *const filters[] = {
"key", "script", "value", NULL
};
enum FilterTypes {
FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
};
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
- Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
+ Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
int index, varc, done, result, satisfied;
- char *pattern;
+ const char *pattern;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ...");
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
@@ -2655,11 +2734,6 @@ DictFilterCmd(
switch ((enum FilterTypes) index) {
case FILTER_KEYS:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "dictionary key globPattern");
- return TCL_ERROR;
- }
-
/*
* Create a dictionary whose keys all match a certain pattern.
*/
@@ -2668,23 +2742,52 @@ DictFilterCmd(
&keyObj, &valueObj, &done) != TCL_OK) {
return TCL_ERROR;
}
- pattern = TclGetString(objv[3]);
- resultObj = Tcl_NewDictObj();
- if (TclMatchIsTrivial(pattern)) {
+ if (objc == 3) {
/*
- * Must release the search lock here to prevent a memory leak
- * since we are not exhausing the search. [Bug 1705778, leak K05]
+ * Nothing to match, so return nothing (== empty dictionary).
*/
Tcl_DictObjDone(&search);
- Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
- if (valueObj != NULL) {
- Tcl_DictObjPut(interp, resultObj, objv[3], valueObj);
+ return TCL_OK;
+ } else if (objc == 4) {
+ pattern = TclGetString(objv[3]);
+ resultObj = Tcl_NewDictObj();
+ if (TclMatchIsTrivial(pattern)) {
+ /*
+ * Must release the search lock here to prevent a memory leak
+ * since we are not exhausing the search. [Bug 1705778, leak
+ * K05]
+ */
+
+ Tcl_DictObjDone(&search);
+ Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
+ if (valueObj != NULL) {
+ Tcl_DictObjPut(interp, resultObj, objv[3], valueObj);
+ }
+ } else {
+ while (!done) {
+ if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
+ Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ }
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
}
} else {
+ /*
+ * Can't optimize this match for trivial globbing: would disturb
+ * order.
+ */
+
+ resultObj = Tcl_NewDictObj();
while (!done) {
- if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ int i;
+
+ for (i=3 ; i<objc ; i++) {
+ pattern = TclGetString(objv[i]);
+ if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
+ Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ break; /* stop inner loop */
+ }
}
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
@@ -2693,11 +2796,6 @@ DictFilterCmd(
return TCL_OK;
case FILTER_VALUES:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "dictionary value globPattern");
- return TCL_ERROR;
- }
-
/*
* Create a dictionary whose values all match a certain pattern.
*/
@@ -2706,11 +2804,16 @@ DictFilterCmd(
&keyObj, &valueObj, &done) != TCL_OK) {
return TCL_ERROR;
}
- pattern = TclGetString(objv[3]);
resultObj = Tcl_NewDictObj();
while (!done) {
- if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ int i;
+
+ for (i=3 ; i<objc ; i++) {
+ pattern = TclGetString(objv[i]);
+ if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
+ Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ break; /* stop inner loop */
+ }
}
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
@@ -2824,7 +2927,7 @@ DictFilterCmd(
case TCL_ERROR:
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"dict filter\" script line %d)",
- interp->errorLine));
+ Tcl_GetErrorLine(interp)));
default:
goto abnormalResult;
}
@@ -2893,8 +2996,7 @@ DictUpdateCmd(
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
- int i, result, dummy;
- Tcl_InterpState state;
+ int i, dummy;
if (objc < 5 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2927,10 +3029,34 @@ DictUpdateCmd(
TclDecrRefCount(dictPtr);
/*
- * Execute the body.
+ * Execute the body after setting up the NRE handler to process the
+ * results.
+ */
+
+ objPtr = Tcl_NewListObj(objc-3, objv+2);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_IncrRefCount(objv[1]);
+ TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
+
+ return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
+}
+
+static int
+FinalizeDictUpdate(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *dictPtr, *objPtr, **objv;
+ Tcl_InterpState state;
+ int i, objc;
+ Tcl_Obj *varName = data[0];
+ Tcl_Obj *argsObj = data[1];
+
+ /*
+ * ErrorInfo handling.
*/
- result = TclEvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")");
}
@@ -2939,8 +3065,10 @@ DictUpdateCmd(
* If the dictionary variable doesn't exist, drop everything silently.
*/
- dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
if (dictPtr == NULL) {
+ TclDecrRefCount(varName);
+ TclDecrRefCount(argsObj);
return result;
}
@@ -2949,8 +3077,10 @@ DictUpdateCmd(
*/
state = Tcl_SaveInterpState(interp, result);
- if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
+ if (Tcl_DictObjSize(interp, dictPtr, &objc) != TCL_OK) {
Tcl_DiscardInterpState(state);
+ TclDecrRefCount(varName);
+ TclDecrRefCount(argsObj);
return TCL_ERROR;
}
@@ -2963,7 +3093,8 @@ DictUpdateCmd(
* an instruction to remove the key.
*/
- for (i=2 ; i+2<objc ; i+=2) {
+ Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv);
+ for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
Tcl_DictObjRemove(interp, dictPtr, objv[i]);
@@ -2980,17 +3111,20 @@ DictUpdateCmd(
Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr);
}
}
+ TclDecrRefCount(argsObj);
/*
* Write the dictionary back to its variable.
*/
- if (Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DiscardInterpState(state);
+ TclDecrRefCount(varName);
return TCL_ERROR;
}
+ TclDecrRefCount(varName);
return Tcl_RestoreInterpState(interp, state);
}
@@ -3020,10 +3154,9 @@ DictWithCmd(
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr;
+ Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr;
Tcl_DictSearch s;
- Tcl_InterpState state;
- int done, result, keyc, i, allocdict = 0;
+ int done;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script");
@@ -3073,10 +3206,34 @@ DictWithCmd(
/*
* Execute the body, while making the invoking context available to the
- * loop body (TIP#280).
+ * loop body (TIP#280) and postponing the cleanup until later (NRE).
*/
- result = TclEvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
+ pathPtr = NULL;
+ if (objc > 3) {
+ pathPtr = Tcl_NewListObj(objc-3, objv+2);
+ Tcl_IncrRefCount(pathPtr);
+ }
+ Tcl_IncrRefCount(objv[1]);
+ TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr,
+ NULL);
+
+ return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
+}
+
+static int
+FinalizeDictWith(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr;
+ int keyc, i, allocdict = 0;
+ Tcl_InterpState state;
+ Tcl_Obj *varName = data[0];
+ Tcl_Obj *keysPtr = data[1];
+ Tcl_Obj *pathPtr = data[2];
+
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
}
@@ -3085,9 +3242,13 @@ DictWithCmd(
* If the dictionary variable doesn't exist, drop everything silently.
*/
- dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
if (dictPtr == NULL) {
+ TclDecrRefCount(varName);
TclDecrRefCount(keysPtr);
+ if (pathPtr) {
+ TclDecrRefCount(pathPtr);
+ }
return result;
}
@@ -3097,7 +3258,11 @@ DictWithCmd(
state = Tcl_SaveInterpState(interp, result);
if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
+ TclDecrRefCount(varName);
TclDecrRefCount(keysPtr);
+ if (pathPtr) {
+ TclDecrRefCount(pathPtr);
+ }
Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
@@ -3107,7 +3272,10 @@ DictWithCmd(
allocdict = 1;
}
- if (objc > 3) {
+ if (pathPtr != NULL) {
+ Tcl_Obj **pathv;
+ int pathc;
+
/*
* Want to get to the dictionary which we will update; need to do
* prepare-for-update de-sharing along the path *but* avoid generating
@@ -3117,9 +3285,12 @@ DictWithCmd(
* perfectly efficient (but no memory should be leaked).
*/
- leafPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2,
+ Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
+ leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
DICT_PATH_EXISTS | DICT_PATH_UPDATE);
+ TclDecrRefCount(pathPtr);
if (leafPtr == NULL) {
+ TclDecrRefCount(varName);
TclDecrRefCount(keysPtr);
if (allocdict) {
TclDecrRefCount(dictPtr);
@@ -3128,6 +3299,7 @@ DictWithCmd(
return TCL_ERROR;
}
if (leafPtr == DICT_PATH_NON_EXISTENT) {
+ TclDecrRefCount(varName);
TclDecrRefCount(keysPtr);
if (allocdict) {
TclDecrRefCount(dictPtr);
@@ -3165,7 +3337,7 @@ DictWithCmd(
* rep.
*/
- if (objc > 3) {
+ if (pathPtr != NULL) {
InvalidateDictChain(leafPtr);
}
@@ -3173,11 +3345,12 @@ DictWithCmd(
* Write back the outermost dictionary to the variable.
*/
- if (Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
+ TclDecrRefCount(varName);
return Tcl_RestoreInterpState(interp, state);
}
@@ -3205,7 +3378,7 @@ TclInitDictCmd(
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 2e0d51f..15411d8 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -11,7 +11,7 @@
#include "tclInt.h"
-typedef size_t (LengthProc)(CONST char *src);
+typedef size_t (LengthProc)(const char *src);
/*
* The following data structure represents an encoding, which describes how to
@@ -92,7 +92,7 @@ typedef struct TableEncodingData {
*/
typedef struct EscapeSubTable {
- unsigned int sequenceLen; /* Length of following string. */
+ unsigned sequenceLen; /* Length of following string. */
char sequence[16]; /* Escape code that marks this encoding. */
char name[32]; /* Name for encoding. */
Encoding *encodingPtr; /* Encoding loaded using above name, or NULL
@@ -104,10 +104,10 @@ typedef struct EscapeEncodingData {
int fallback; /* Character (in this encoding) to substitute
* when this encoding cannot represent a UTF-8
* character. */
- unsigned int initLen; /* Length of following string. */
+ unsigned initLen; /* Length of following string. */
char init[16]; /* String to emit or expect before first char
* in conversion. */
- unsigned int finalLen; /* Length of following string. */
+ unsigned finalLen; /* Length of following string. */
char final[16]; /* String to emit or expect after last char in
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
@@ -195,19 +195,19 @@ static unsigned short emptyPage[256];
*/
static int BinaryProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static void DupEncodingIntRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void EscapeFreeProc(ClientData clientData);
static int EscapeFromUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int EscapeToUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
@@ -216,55 +216,55 @@ static void FreeEncoding(Tcl_Encoding encoding);
static void FreeEncodingIntRep(Tcl_Obj *objPtr);
static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr,
int state);
-static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp, CONST char *name);
-static Tcl_Encoding LoadTableEncoding(CONST char *name, int type,
+static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp, const char *name);
+static Tcl_Encoding LoadTableEncoding(const char *name, int type,
Tcl_Channel chan);
-static Tcl_Encoding LoadEscapeEncoding(CONST char *name, Tcl_Channel chan);
+static Tcl_Encoding LoadEscapeEncoding(const char *name, Tcl_Channel chan);
static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp,
- CONST char *name);
+ const char *name);
static void TableFreeProc(ClientData clientData);
static int TableFromUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static int TableToUtfProc(ClientData clientData, CONST char *src,
+static int TableToUtfProc(ClientData clientData, const char *src,
int srcLen, int flags, Tcl_EncodingState *statePtr,
char *dst, int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
-static size_t unilen(CONST char *src);
+static size_t unilen(const char *src);
static int UnicodeToUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int UtfToUnicodeProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int UtfToUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr, int pureNullMode);
static int UtfIntToUtfExtProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int UtfExtToUtfIntProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int Iso88591FromUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
static int Iso88591ToUtfProc(ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
@@ -275,7 +275,7 @@ static int Iso88591ToUtfProc(ClientData clientData,
* See concerns raised in [Bug 1077262].
*/
-static Tcl_ObjType encodingType = {
+static const Tcl_ObjType encodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
@@ -293,7 +293,7 @@ static Tcl_ObjType encodingType = {
* Standard Tcl return code.
*
* Side effects:
- * Caches the Tcl_Encoding value as the internal rep of (*objPtr).
+ * Caches the Tcl_Encoding value as the internal rep of (*objPtr).
*
*----------------------------------------------------------------------
*/
@@ -304,7 +304,8 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
- CONST char *name = Tcl_GetString(objPtr);
+ const char *name = Tcl_GetString(objPtr);
+
if (objPtr->typePtr != &encodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
@@ -312,7 +313,7 @@ Tcl_GetEncodingFromObj(
return TCL_ERROR;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = (VOID *) encoding;
+ objPtr->internalRep.otherValuePtr = encoding;
objPtr->typePtr = &encodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
@@ -333,7 +334,7 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr);
+ Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr);
objPtr->typePtr = NULL;
}
@@ -352,8 +353,7 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.otherValuePtr = (VOID *)
- Tcl_GetEncoding(NULL, srcPtr->bytes);
+ dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
@@ -452,8 +452,8 @@ TclSetLibraryPath(
*
* FillEncodingFileMap --
*
- * Called to bring the encoding file map in sync with the current value
- * of the encoding search path.
+ * Called to bring the encoding file map in sync with the current value
+ * of the encoding search path.
*
* Scan the directories on the encoding search path, find the *.enc
* files, and store the found pathnames in a map associated with the
@@ -506,12 +506,12 @@ FillEncodingFileMap(void)
Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev);
for (j=0; j<numFiles; j++) {
- Tcl_Obj *encodingName, *file;
+ Tcl_Obj *encodingName, *fileObj;
- file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
- encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT);
+ fileObj = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
+ encodingName = TclPathPart(NULL, fileObj, TCL_PATH_ROOT);
Tcl_DictObjPut(NULL, map, encodingName, directory);
- Tcl_DecrRefCount(file);
+ Tcl_DecrRefCount(fileObj);
Tcl_DecrRefCount(encodingName);
}
Tcl_DecrRefCount(matchFileList);
@@ -543,6 +543,9 @@ void
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
+ TableEncodingData *dataPtr;
+ unsigned size;
+ unsigned short i;
if (encodingsInitialized) {
return;
@@ -564,9 +567,7 @@ TclInitEncodingSubsystem(void)
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
-
- defaultEncoding = Tcl_CreateEncoding(&type);
- systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
+ Tcl_CreateEncoding(&type);
type.encodingName = "utf-8";
type.toUtfProc = UtfExtToUtfIntProc;
@@ -591,43 +592,37 @@ TclInitEncodingSubsystem(void)
* code to duplicate the structure of a table encoding here.
*/
- {
- TableEncodingData *dataPtr = (TableEncodingData *)
- ckalloc(sizeof(TableEncodingData));
- unsigned size;
- unsigned short i;
-
- memset(dataPtr, 0, sizeof(TableEncodingData));
- dataPtr->fallback = '?';
-
- size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
- dataPtr->toUnicode = (unsigned short **) ckalloc(size);
- memset(dataPtr->toUnicode, 0, size);
- dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
- memset(dataPtr->fromUnicode, 0, size);
-
- dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256);
- dataPtr->fromUnicode[0] = (unsigned short *)
- (dataPtr->fromUnicode + 256);
- for (i=1 ; i<256 ; i++) {
- dataPtr->toUnicode[i] = emptyPage;
- dataPtr->fromUnicode[i] = emptyPage;
- }
+ dataPtr = ckalloc(sizeof(TableEncodingData));
+ memset(dataPtr, 0, sizeof(TableEncodingData));
+ dataPtr->fallback = '?';
- for (i=0 ; i<256 ; i++) {
- dataPtr->toUnicode[0][i] = i;
- dataPtr->fromUnicode[0][i] = i;
- }
+ size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
+ dataPtr->toUnicode = ckalloc(size);
+ memset(dataPtr->toUnicode, 0, size);
+ dataPtr->fromUnicode = ckalloc(size);
+ memset(dataPtr->fromUnicode, 0, size);
- type.encodingName = "iso8859-1";
- type.toUtfProc = Iso88591ToUtfProc;
- type.fromUtfProc = Iso88591FromUtfProc;
- type.freeProc = TableFreeProc;
- type.nullSize = 1;
- type.clientData = dataPtr;
- Tcl_CreateEncoding(&type);
+ dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256);
+ dataPtr->fromUnicode[0] = (unsigned short *) (dataPtr->fromUnicode + 256);
+ for (i=1 ; i<256 ; i++) {
+ dataPtr->toUnicode[i] = emptyPage;
+ dataPtr->fromUnicode[i] = emptyPage;
}
+ for (i=0 ; i<256 ; i++) {
+ dataPtr->toUnicode[0][i] = i;
+ dataPtr->fromUnicode[0][i] = i;
+ }
+
+ type.encodingName = "iso8859-1";
+ type.toUtfProc = Iso88591ToUtfProc;
+ type.fromUtfProc = Iso88591FromUtfProc;
+ type.freeProc = TableFreeProc;
+ type.nullSize = 1;
+ type.clientData = dataPtr;
+ defaultEncoding = Tcl_CreateEncoding(&type);
+ systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
+
encodingsInitialized = 1;
}
@@ -666,7 +661,7 @@ TclFinalizeEncodingSubsystem(void)
* cleaned up.
*/
- FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
+ FreeEncoding(Tcl_GetHashValue(hPtr));
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
}
@@ -679,20 +674,20 @@ TclFinalizeEncodingSubsystem(void)
*
* Tcl_GetDefaultEncodingDir --
*
- * Legacy public interface to retrieve first directory in the encoding
- * searchPath.
+ * Legacy public interface to retrieve first directory in the encoding
+ * searchPath.
*
* Results:
* The directory pathname, as a string, or NULL for an empty encoding
* search path.
*
* Side effects:
- * None.
+ * None.
*
*-------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_GetDefaultEncodingDir(void)
{
int numDirs;
@@ -712,21 +707,21 @@ Tcl_GetDefaultEncodingDir(void)
*
* Tcl_SetDefaultEncodingDir --
*
- * Legacy public interface to set the first directory in the encoding
- * search path.
+ * Legacy public interface to set the first directory in the encoding
+ * search path.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Modifies the encoding search path.
+ * Modifies the encoding search path.
*
*-------------------------------------------------------------------------
*/
void
Tcl_SetDefaultEncodingDir(
- CONST char *path)
+ const char *path)
{
Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath();
Tcl_Obj *directory = Tcl_NewStringObj(path, -1);
@@ -764,7 +759,7 @@ Tcl_SetDefaultEncodingDir(
Tcl_Encoding
Tcl_GetEncoding(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
- CONST char *name) /* The name of the desired encoding. */
+ const char *name) /* The name of the desired encoding. */
{
Tcl_HashEntry *hPtr;
Encoding *encodingPtr;
@@ -779,7 +774,7 @@ Tcl_GetEncoding(
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
- encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ encodingPtr = Tcl_GetHashValue(hPtr);
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return (Tcl_Encoding) encodingPtr;
@@ -838,9 +833,8 @@ static void
FreeEncoding(
Tcl_Encoding encoding)
{
- Encoding *encodingPtr;
+ Encoding *encodingPtr = (Encoding *) encoding;
- encodingPtr = (Encoding *) encoding;
if (encodingPtr == NULL) {
return;
}
@@ -850,13 +844,13 @@ FreeEncoding(
encodingPtr->refCount--;
if (encodingPtr->refCount == 0) {
if (encodingPtr->freeProc != NULL) {
- (*encodingPtr->freeProc)(encodingPtr->clientData);
+ encodingPtr->freeProc(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
- ckfree((char *) encodingPtr->name);
- ckfree((char *) encodingPtr);
+ ckfree(encodingPtr->name);
+ ckfree(encodingPtr);
}
}
@@ -877,7 +871,7 @@ FreeEncoding(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_GetEncodingName(
Tcl_Encoding encoding) /* The encoding whose name to fetch. */
{
@@ -926,9 +920,10 @@ Tcl_GetEncodingNames(
Tcl_MutexLock(&encodingMutex);
for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ Encoding *encodingPtr = Tcl_GetHashValue(hPtr);
+
Tcl_CreateHashEntry(&table,
- (char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
+ Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
}
Tcl_MutexUnlock(&encodingMutex);
@@ -941,7 +936,7 @@ Tcl_GetEncodingNames(
Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done);
for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) {
- Tcl_CreateHashEntry(&table, (char *) name, &dummy);
+ Tcl_CreateHashEntry(&table, name, &dummy);
}
/*
@@ -984,7 +979,7 @@ Tcl_GetEncodingNames(
int
Tcl_SetSystemEncoding(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
- CONST char *name) /* The name of the desired encoding, or NULL
+ const char *name) /* The name of the desired encoding, or NULL
* to reset to default encoding. */
{
Tcl_Encoding encoding;
@@ -1055,13 +1050,13 @@ Tcl_CreateEncoding(
* reference goes away.
*/
- encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ encodingPtr = Tcl_GetHashValue(hPtr);
encodingPtr->hPtr = NULL;
}
- name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);
+ name = ckalloc(strlen(typePtr->encodingName) + 1);
- encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
+ encodingPtr = ckalloc(sizeof(Encoding));
encodingPtr->name = strcpy(name, typePtr->encodingName);
encodingPtr->toUtfProc = typePtr->toUtfProc;
encodingPtr->fromUtfProc = typePtr->fromUtfProc;
@@ -1107,7 +1102,7 @@ char *
Tcl_ExternalToUtfDString(
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
- CONST char *src, /* Source string in specified encoding. */
+ const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
@@ -1115,7 +1110,7 @@ Tcl_ExternalToUtfDString(
{
char *dst;
Tcl_EncodingState state;
- Encoding *encodingPtr;
+ const Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
@@ -1130,15 +1125,14 @@ Tcl_ExternalToUtfDString(
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
- srcLen = (*encodingPtr->lengthProc)(src);
+ srcLen = encodingPtr->lengthProc(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
- result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
- srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
- &dstChars);
+ result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
+ flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
if (result != TCL_CONVERT_NOSPACE) {
@@ -1181,7 +1175,7 @@ Tcl_ExternalToUtf(
Tcl_Interp *interp, /* Interp for error return, if not NULL. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
- CONST char *src, /* Source string in specified encoding. */
+ const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags, /* Conversion control flags. */
@@ -1206,7 +1200,7 @@ Tcl_ExternalToUtf(
* correspond to the bytes stored in the
* output buffer. */
{
- Encoding *encodingPtr;
+ const Encoding *encodingPtr;
int result, srcRead, dstWrote, dstChars;
Tcl_EncodingState state;
@@ -1218,7 +1212,7 @@ Tcl_ExternalToUtf(
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
- srcLen = (*encodingPtr->lengthProc)(src);
+ srcLen = encodingPtr->lengthProc(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
@@ -1241,7 +1235,7 @@ Tcl_ExternalToUtf(
*/
dstLen--;
- result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
+ result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
dst[*dstWrotePtr] = '\0';
@@ -1274,7 +1268,7 @@ char *
Tcl_UtfToExternalDString(
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
@@ -1282,7 +1276,7 @@ Tcl_UtfToExternalDString(
{
char *dst;
Tcl_EncodingState state;
- Encoding *encodingPtr;
+ const Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
@@ -1301,7 +1295,7 @@ Tcl_UtfToExternalDString(
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
- result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
+ result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
&dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
@@ -1349,7 +1343,7 @@ Tcl_UtfToExternal(
Tcl_Interp *interp, /* Interp for error return, if not NULL. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
int flags, /* Conversion control flags. */
@@ -1374,7 +1368,7 @@ Tcl_UtfToExternal(
* correspond to the bytes stored in the
* output buffer. */
{
- Encoding *encodingPtr;
+ const Encoding *encodingPtr;
int result, srcRead, dstWrote, dstChars;
Tcl_EncodingState state;
@@ -1403,7 +1397,7 @@ Tcl_UtfToExternal(
}
dstLen -= encodingPtr->nullSize;
- result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
+ result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
if (encodingPtr->nullSize == 2) {
@@ -1431,10 +1425,10 @@ Tcl_UtfToExternal(
*
*---------------------------------------------------------------------------
*/
-
+#undef Tcl_FindExecutable
void
Tcl_FindExecutable(
- CONST char *argv0) /* The value of the application's argv[0]
+ const char *argv0) /* The value of the application's argv[0]
* (native). */
{
TclInitSubsystems();
@@ -1450,9 +1444,9 @@ Tcl_FindExecutable(
* Open the file believed to hold data for the encoding, "name".
*
* Results:
- * Returns the readable Tcl_Channel from opening the file, or NULL if the
- * file could not be successfully opened. If NULL was returned, an error
- * message is left in interp's result object, unless interp was NULL.
+ * Returns the readable Tcl_Channel from opening the file, or NULL if the
+ * file could not be successfully opened. If NULL was returned, an error
+ * message is left in interp's result object, unless interp was NULL.
*
* Side effects:
* Channel may be opened. Information about the filesystem may be cached
@@ -1464,7 +1458,7 @@ Tcl_FindExecutable(
static Tcl_Channel
OpenEncodingFileChannel(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
- CONST char *name) /* The name of the encoding file on disk and
+ const char *name) /* The name of the encoding file on disk and
* also the name for new encoding. */
{
Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
@@ -1494,7 +1488,8 @@ OpenEncodingFileChannel(
}
}
if (!verified) {
- CONST char *dirString = Tcl_GetString(directory);
+ const char *dirString = Tcl_GetString(directory);
+
for (i=0; i<numDirs && !verified; i++) {
if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) {
verified = 1;
@@ -1580,7 +1575,7 @@ OpenEncodingFileChannel(
static Tcl_Encoding
LoadEncodingFile(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
- CONST char *name) /* The name of the encoding file on disk and
+ const char *name) /* The name of the encoding file on disk and
* also the name for new encoding. */
{
Tcl_Channel chan = NULL;
@@ -1622,6 +1617,7 @@ LoadEncodingFile(
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_Close(NULL, chan);
@@ -1653,18 +1649,18 @@ LoadEncodingFile(
static Tcl_Encoding
LoadTableEncoding(
- CONST char *name, /* Name for new encoding. */
+ const char *name, /* Name for new encoding. */
int type, /* Type of encoding (ENCODING_?????). */
Tcl_Channel chan) /* File containing new encoding. */
{
Tcl_DString lineString;
Tcl_Obj *objPtr;
char *line;
- int i, hi, lo, numPages, symbol, fallback;
+ int i, hi, lo, numPages, symbol, fallback, len;
unsigned char used[256];
- unsigned int size;
+ unsigned size;
TableEncodingData *dataPtr;
- unsigned short *pageMemPtr;
+ unsigned short *pageMemPtr, *page;
Tcl_EncodingType encType;
/*
@@ -1672,7 +1668,7 @@ LoadTableEncoding(
* sequences in the encoding files.
*/
- static char staticHex[] = {
+ static const char staticHex[] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */
@@ -1711,7 +1707,7 @@ LoadTableEncoding(
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
- dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
+ dataPtr = ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = fallback;
@@ -1723,7 +1719,7 @@ LoadTableEncoding(
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
- dataPtr->toUnicode = (unsigned short **) ckalloc(size);
+ dataPtr->toUnicode = ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
@@ -1731,7 +1727,7 @@ LoadTableEncoding(
Tcl_IncrRefCount(objPtr);
for (i = 0; i < numPages; i++) {
int ch;
- char *p;
+ const char *p;
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
p = Tcl_GetString(objPtr);
@@ -1781,29 +1777,26 @@ LoadTableEncoding(
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
- dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
+ dataPtr->fromUnicode = ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
for (hi = 0; hi < 256; hi++) {
if (dataPtr->toUnicode[hi] == NULL) {
dataPtr->toUnicode[hi] = emptyPage;
- } else {
- for (lo = 0; lo < 256; lo++) {
- int ch;
-
- ch = dataPtr->toUnicode[hi][lo];
- if (ch != 0) {
- unsigned short *page;
-
- page = dataPtr->fromUnicode[ch >> 8];
- if (page == NULL) {
- page = pageMemPtr;
- pageMemPtr += 256;
- dataPtr->fromUnicode[ch >> 8] = page;
- }
- page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
+ continue;
+ }
+ for (lo = 0; lo < 256; lo++) {
+ int ch = dataPtr->toUnicode[hi][lo];
+
+ if (ch != 0) {
+ page = dataPtr->fromUnicode[ch >> 8];
+ if (page == NULL) {
+ page = pageMemPtr;
+ pageMemPtr += 256;
+ dataPtr->fromUnicode[ch >> 8] = page;
}
+ page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
}
}
}
@@ -1822,8 +1815,6 @@ LoadTableEncoding(
}
}
if (symbol) {
- unsigned short *page;
-
/*
* Make a special symbol encoding that not only maps the symbol
* characters from their Unicode code points down into page 0, but
@@ -1831,7 +1822,7 @@ LoadTableEncoding(
* is so that a symbol font can be used to display a simple string
* like "abcd" and have alpha, beta, chi, delta show up, rather than
* have "unknown" chars show up because strictly speaking the symbol
- * font doesn't have glyphs for those low ascii chars.
+ * font doesn't have glyphs for those low ASCII chars.
*/
page = dataPtr->fromUnicode[0];
@@ -1856,57 +1847,77 @@ LoadTableEncoding(
*/
Tcl_DStringInit(&lineString);
- do {
- int len;
+
+ /*
+ * Skip leading empty lines.
+ */
+
+ while ((len = Tcl_Gets(chan, &lineString)) == 0) {
+ /* empty body */
+ }
+ if (len < 0) {
+ goto doneParse;
+ }
+
+ /*
+ * Require that it starts with an 'R'.
+ */
+
+ line = Tcl_DStringValue(&lineString);
+ if (line[0] != 'R') {
+ goto doneParse;
+ }
+
+ /*
+ * Read lines from the encoding until EOF.
+ */
+
+ for (Tcl_DStringSetLength(&lineString, 0);
+ (len = Tcl_Gets(chan, &lineString)) >= 0;
+ Tcl_DStringSetLength(&lineString, 0)) {
+ const unsigned char *p;
+ int to, from;
/*
- * Skip leading empty lines.
+ * Skip short lines.
*/
- while ((len = Tcl_Gets(chan, &lineString)) == 0) {
- /* empty body */
+ if (len < 5) {
+ continue;
}
- if (len < 0) {
- break;
- }
- line = Tcl_DStringValue(&lineString);
- if (line[0] != 'R') {
- break;
- }
- for (Tcl_DStringSetLength(&lineString, 0);
- (len = Tcl_Gets(chan, &lineString)) >= 0;
- Tcl_DStringSetLength(&lineString, 0)) {
- unsigned char* p;
- int to, from;
+ /*
+ * Parse the line as a sequence of hex digits.
+ */
- if (len < 5) {
- continue;
- }
- p = (unsigned char*) Tcl_DStringValue(&lineString);
- to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ p = (const unsigned char *) Tcl_DStringValue(&lineString);
+ to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ + (staticHex[p[2]] << 4) + staticHex[p[3]];
+ if (to == 0) {
+ continue;
+ }
+ for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
+ from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
- if (to == 0) {
- continue;
- }
- for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
- from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
- + (staticHex[p[2]] << 4) + staticHex[p[3]];
- if (from == 0) {
- continue;
- }
- dataPtr->fromUnicode[from >> 8][from & 0xff] = to;
+ if (from == 0) {
+ continue;
}
+ dataPtr->fromUnicode[from >> 8][from & 0xff] = to;
}
- } while (0);
+ }
+ doneParse:
Tcl_DStringFree(&lineString);
+ /*
+ * Package everything into an encoding structure.
+ */
+
encType.encodingName = name;
encType.toUtfProc = TableToUtfProc;
encType.fromUtfProc = TableFromUtfProc;
encType.freeProc = TableFreeProc;
encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
- encType.clientData = (ClientData) dataPtr;
+ encType.clientData = dataPtr;
return Tcl_CreateEncoding(&encType);
}
@@ -1935,11 +1946,11 @@ LoadTableEncoding(
static Tcl_Encoding
LoadEscapeEncoding(
- CONST char *name, /* Name for new encoding. */
+ const char *name, /* Name for new encoding. */
Tcl_Channel chan) /* File containing new encoding. */
{
int i;
- unsigned int size;
+ unsigned size;
Tcl_DString escapeData;
char init[16], final[16];
EscapeEncodingData *dataPtr;
@@ -1951,7 +1962,7 @@ LoadEscapeEncoding(
while (1) {
int argc;
- CONST char **argv;
+ const char **argv;
char *line;
Tcl_DString lineString;
@@ -1961,6 +1972,7 @@ LoadEscapeEncoding(
}
line = Tcl_DStringValue(&lineString);
if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
+ Tcl_DStringFree(&lineString);
continue;
}
if (argc >= 2) {
@@ -1988,8 +2000,8 @@ LoadEscapeEncoding(
*/
e = (Encoding *) Tcl_GetEncoding(NULL, est.name);
- if (e && e->toUtfProc != TableToUtfProc &&
- e->toUtfProc != Iso88591ToUtfProc) {
+ if ((e != NULL) && (e->toUtfProc != TableToUtfProc)
+ && (e->toUtfProc != Iso88591ToUtfProc)) {
Tcl_FreeEncoding((Tcl_Encoding) e);
e = NULL;
}
@@ -1997,17 +2009,17 @@ LoadEscapeEncoding(
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
- ckfree((char *) argv);
+ ckfree(argv);
Tcl_DStringFree(&lineString);
}
size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
+ Tcl_DStringLength(&escapeData);
- dataPtr = (EscapeEncodingData *) ckalloc(size);
+ dataPtr = ckalloc(size);
dataPtr->initLen = strlen(init);
- strcpy(dataPtr->init, init);
+ memcpy(dataPtr->init, init, (unsigned) dataPtr->initLen + 1);
dataPtr->finalLen = strlen(final);
- strcpy(dataPtr->final, final);
+ memcpy(dataPtr->final, final, (unsigned) dataPtr->finalLen + 1);
dataPtr->numSubTables =
Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData),
@@ -2025,12 +2037,16 @@ LoadEscapeEncoding(
dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1;
}
+ /*
+ * Package everything into an encoding structure.
+ */
+
type.encodingName = name;
type.toUtfProc = EscapeToUtfProc;
type.fromUtfProc = EscapeFromUtfProc;
type.freeProc = EscapeFreeProc;
type.nullSize = 1;
- type.clientData = (ClientData) dataPtr;
+ type.clientData = dataPtr;
return Tcl_CreateEncoding(&type);
}
@@ -2056,7 +2072,7 @@ LoadEscapeEncoding(
static int
BinaryProc(
ClientData clientData, /* Not used. */
- CONST char *src, /* Source string (unknown encoding). */
+ const char *src, /* Source string (unknown encoding). */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2117,7 +2133,7 @@ BinaryProc(
static int
UtfIntToUtfExtProc(
ClientData clientData, /* Not used. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2162,10 +2178,11 @@ UtfIntToUtfExtProc(
*
*-------------------------------------------------------------------------
*/
+
static int
UtfExtToUtfIntProc(
ClientData clientData, /* Not used. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2214,7 +2231,7 @@ UtfExtToUtfIntProc(
static int
UtfToUtfProc(
ClientData clientData, /* Not used. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2241,8 +2258,8 @@ UtfToUtfProc(
* representation to real null-bytes or vice
* versa. */
{
- CONST char *srcStart, *srcEnd, *srcClose;
- char *dstStart, *dstEnd;
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
@@ -2328,7 +2345,7 @@ UtfToUtfProc(
static int
UnicodeToUtfProc(
ClientData clientData, /* Not used. */
- CONST char *src, /* Source string in Unicode. */
+ const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2352,8 +2369,8 @@ UnicodeToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd;
- char *dstEnd, *dstStart;
+ const char *srcStart, *srcEnd;
+ const char *dstEnd, *dstStart;
int result, numChars;
Tcl_UniChar ch;
@@ -2375,10 +2392,12 @@ UnicodeToUtfProc(
result = TCL_CONVERT_NOSPACE;
break;
}
+
/*
- * Special case for 1-byte utf chars for speed. Make sure we
- * work with Tcl_UniChar-size data.
+ * Special case for 1-byte utf chars for speed. Make sure we work with
+ * Tcl_UniChar-size data.
*/
+
ch = *(Tcl_UniChar *)src;
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
@@ -2414,7 +2433,7 @@ static int
UtfToUnicodeProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2438,7 +2457,7 @@ UtfToUnicodeProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
+ const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
@@ -2468,11 +2487,13 @@ UtfToUnicodeProc(
break;
}
src += TclUtfToUniChar(src, &ch);
+
/*
- * Need to handle this in a way that won't cause misalignment
- * by casting dst to a Tcl_UniChar. [Bug 1122671]
+ * Need to handle this in a way that won't cause misalignment by
+ * casting dst to a Tcl_UniChar. [Bug 1122671]
* XXX: This hard-codes the assumed size of Tcl_UniChar as 2.
*/
+
#ifdef WORDS_BIGENDIAN
*dst++ = (ch >> 8);
*dst++ = (ch & 0xFF);
@@ -2508,7 +2529,7 @@ static int
TableToUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
- CONST char *src, /* Source string in specified encoding. */
+ const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2532,13 +2553,13 @@ TableToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd;
- char *dstEnd, *dstStart, *prefixBytes;
+ const char *srcStart, *srcEnd;
+ const char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars;
Tcl_UniChar ch;
- unsigned short **toUnicode;
- unsigned short *pageZero;
- TableEncodingData *dataPtr;
+ const unsigned short *const *toUnicode;
+ const unsigned short *pageZero;
+ TableEncodingData *dataPtr = clientData;
srcStart = src;
srcEnd = src + srcLen;
@@ -2546,8 +2567,7 @@ TableToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
- dataPtr = (TableEncodingData *) clientData;
- toUnicode = dataPtr->toUnicode;
+ toUnicode = (const unsigned short *const *) dataPtr->toUnicode;
prefixBytes = dataPtr->prefixBytes;
pageZero = toUnicode[0];
@@ -2579,9 +2599,11 @@ TableToUtfProc(
}
ch = (Tcl_UniChar) byte;
}
+
/*
* Special case for 1-byte utf chars for speed.
*/
+
if (ch && ch < 0x80) {
*dst++ = (char) ch;
} else {
@@ -2617,7 +2639,7 @@ static int
TableFromUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2641,18 +2663,17 @@ TableFromUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd, *srcClose;
- char *dstStart, *dstEnd, *prefixBytes;
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd, *prefixBytes;
Tcl_UniChar ch;
int result, len, word, numChars;
- TableEncodingData *dataPtr;
- unsigned short **fromUnicode;
+ TableEncodingData *dataPtr = clientData;
+ const unsigned short *const *fromUnicode;
result = TCL_OK;
- dataPtr = (TableEncodingData *) clientData;
prefixBytes = dataPtr->prefixBytes;
- fromUnicode = dataPtr->fromUnicode;
+ fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode;
srcStart = src;
srcEnd = src + srcLen;
@@ -2739,7 +2760,7 @@ TableFromUtfProc(
static int
Iso88591ToUtfProc(
ClientData clientData, /* Ignored. */
- CONST char *src, /* Source string in specified encoding. */
+ const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2763,8 +2784,8 @@ Iso88591ToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd;
- char *dstEnd, *dstStart;
+ const char *srcStart, *srcEnd;
+ const char *dstEnd, *dstStart;
int result, numChars;
srcStart = src;
@@ -2782,9 +2803,11 @@ Iso88591ToUtfProc(
break;
}
ch = (Tcl_UniChar) *((unsigned char *) src);
+
/*
* Special case for 1-byte utf chars for speed.
*/
+
if (ch && ch < 0x80) {
*dst++ = (char) ch;
} else {
@@ -2818,7 +2841,7 @@ Iso88591ToUtfProc(
static int
Iso88591FromUtfProc(
ClientData clientData, /* Ignored. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2842,8 +2865,8 @@ Iso88591FromUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- CONST char *srcStart, *srcEnd, *srcClose;
- char *dstStart, *dstEnd;
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd;
int result, numChars;
result = TCL_OK;
@@ -2926,16 +2949,15 @@ TableFreeProc(
ClientData clientData) /* TableEncodingData that specifies
* encoding. */
{
- TableEncodingData *dataPtr;
+ TableEncodingData *dataPtr = clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
*/
- dataPtr = (TableEncodingData *) clientData;
- ckfree((char *) dataPtr->toUnicode);
- ckfree((char *) dataPtr->fromUnicode);
- ckfree((char *) dataPtr);
+ ckfree(dataPtr->toUnicode);
+ ckfree(dataPtr->fromUnicode);
+ ckfree(dataPtr);
}
/*
@@ -2959,7 +2981,7 @@ static int
EscapeToUtfProc(
ClientData clientData, /* EscapeEncodingData that specifies
* encoding. */
- CONST char *src, /* Source string in specified encoding. */
+ const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -2983,20 +3005,16 @@ EscapeToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- EscapeEncodingData *dataPtr;
- char *prefixBytes, *tablePrefixBytes;
- unsigned short **tableToUnicode;
- Encoding *encodingPtr;
+ EscapeEncodingData *dataPtr = clientData;
+ const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd;
+ const unsigned short *const *tableToUnicode;
+ const Encoding *encodingPtr;
int state, result, numChars;
- CONST char *srcStart, *srcEnd;
- char *dstStart, *dstEnd;
+ const char *dstStart, *dstEnd;
result = TCL_OK;
-
tablePrefixBytes = NULL; /* lint. */
tableToUnicode = NULL; /* lint. */
-
- dataPtr = (EscapeEncodingData *) clientData;
prefixBytes = dataPtr->prefixBytes;
encodingPtr = NULL;
@@ -3020,9 +3038,9 @@ EscapeToUtfProc(
}
byte = *((unsigned char *) src);
if (prefixBytes[byte]) {
- unsigned int left, len, longest;
+ unsigned left, len, longest;
int checked, i;
- EscapeSubTable *subTablePtr;
+ const EscapeSubTable *subTablePtr;
/*
* Saw the beginning of an escape sequence.
@@ -3120,9 +3138,10 @@ EscapeToUtfProc(
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
- tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ tableDataPtr = encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
- tableToUnicode = tableDataPtr->toUnicode;
+ tableToUnicode = (const unsigned short *const*)
+ tableDataPtr->toUnicode;
}
if (tablePrefixBytes[byte]) {
@@ -3173,7 +3192,7 @@ static int
EscapeFromUtfProc(
ClientData clientData, /* EscapeEncodingData that specifies
* encoding. */
- CONST char *src, /* Source string in UTF-8. */
+ const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -3197,19 +3216,17 @@ EscapeFromUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- EscapeEncodingData *dataPtr;
- Encoding *encodingPtr;
- CONST char *srcStart, *srcEnd, *srcClose;
- char *dstStart, *dstEnd;
+ EscapeEncodingData *dataPtr = clientData;
+ const Encoding *encodingPtr;
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd;
int state, result, numChars;
- TableEncodingData *tableDataPtr;
- char *tablePrefixBytes;
- unsigned short **tableFromUnicode;
+ const TableEncodingData *tableDataPtr;
+ const char *tablePrefixBytes;
+ const unsigned short *const *tableFromUnicode;
result = TCL_OK;
- dataPtr = (EscapeEncodingData *) clientData;
-
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
@@ -3221,7 +3238,7 @@ EscapeFromUtfProc(
dstEnd = dst + dstLen - 1;
/*
- * RFC1468 states that the text starts in ASCII, and switches to Japanese
+ * RFC 1468 states that the text starts in ASCII, and switches to Japanese
* characters, and that the text must end in ASCII. [Patch 474358]
*/
@@ -3239,12 +3256,13 @@ EscapeFromUtfProc(
}
encodingPtr = GetTableEncoding(dataPtr, state);
- tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ tableDataPtr = encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
- tableFromUnicode = tableDataPtr->fromUnicode;
+ tableFromUnicode = (const unsigned short *const *)
+ tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
- unsigned int len;
+ unsigned len;
int word;
Tcl_UniChar ch;
@@ -3262,13 +3280,13 @@ EscapeFromUtfProc(
if ((word == 0) && (ch != 0)) {
int oldState;
- EscapeSubTable *subTablePtr;
+ const EscapeSubTable *subTablePtr;
oldState = state;
for (state = 0; state < dataPtr->numSubTables; state++) {
encodingPtr = GetTableEncoding(dataPtr, state);
- tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
- word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
+ tableDataPtr = encodingPtr->clientData;
+ word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
if (word != 0) {
break;
}
@@ -3281,12 +3299,13 @@ EscapeFromUtfProc(
break;
}
encodingPtr = GetTableEncoding(dataPtr, state);
- tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ tableDataPtr = encodingPtr->clientData;
word = tableDataPtr->fallback;
}
- tablePrefixBytes = tableDataPtr->prefixBytes;
- tableFromUnicode = tableDataPtr->fromUnicode;
+ tablePrefixBytes = (const char *) tableDataPtr->prefixBytes;
+ tableFromUnicode = (const unsigned short *const *)
+ tableDataPtr->fromUnicode;
/*
* The state variable has the value of oldState when word is 0.
@@ -3334,22 +3353,22 @@ EscapeFromUtfProc(
}
if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
- unsigned int len = dataPtr->subTables[0].sequenceLen;
+ unsigned len = dataPtr->subTables[0].sequenceLen;
+
/*
- * Certain encodings like iso2022-jp need to write
- * an escape sequence after all characters have
- * been converted. This logic checks that enough
- * room is available in the buffer for the escape bytes.
- * The TCL_ENCODING_END flag is cleared after a final
- * escape sequence has been added to the buffer so
- * that another call to this method does not attempt
- * to append escape bytes a second time.
+ * Certain encodings like iso2022-jp need to write an escape sequence
+ * after all characters have been converted. This logic checks that
+ * enough room is available in the buffer for the escape bytes. The
+ * TCL_ENCODING_END flag is cleared after a final escape sequence has
+ * been added to the buffer so that another call to this method does
+ * not attempt to append escape bytes a second time.
*/
+
if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (state) {
- memcpy(dst, dataPtr->subTables[0].sequence, (size_t) len);
+ memcpy(dst, dataPtr->subTables[0].sequence, len);
dst += len;
}
memcpy(dst, dataPtr->final, (size_t) dataPtr->finalLen);
@@ -3387,33 +3406,33 @@ EscapeFreeProc(
ClientData clientData) /* EscapeEncodingData that specifies
* encoding. */
{
- EscapeEncodingData *dataPtr;
+ EscapeEncodingData *dataPtr = clientData;
EscapeSubTable *subTablePtr;
int i;
- dataPtr = (EscapeEncodingData *) clientData;
if (dataPtr == NULL) {
return;
}
+
/*
- * The subTables should be freed recursively in normal operation but not
- * during TclFinalizeEncodingSubsystem because they are also present as a
- * weak reference in the toplevel encodingTable (ie they don't have a +1
- * refcount for this), and unpredictable nuking order could remove them
- * from under the following loop's feet [Bug 2891556].
- *
- * The encodingsInitialized flag, being reset on entry to TFES, can serve
- * as a "not in finalization" test.
+ * The subTables should be freed recursively in normal operation but not
+ * during TclFinalizeEncodingSubsystem because they are also present as a
+ * weak reference in the toplevel encodingTable (i.e., they don't have a
+ * +1 refcount for this), and unpredictable nuking order could remove them
+ * from under the following loop's feet. [Bug 2891556]
+ *
+ * The encodingsInitialized flag, being reset on entry to TFES, can serve
+ * as a "not in finalization" test.
*/
- if (encodingsInitialized)
- {
- subTablePtr = dataPtr->subTables;
- for (i = 0; i < dataPtr->numSubTables; i++) {
- FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
- subTablePtr++;
- }
+
+ if (encodingsInitialized) {
+ subTablePtr = dataPtr->subTables;
+ for (i = 0; i < dataPtr->numSubTables; i++) {
+ FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
+ subTablePtr++;
}
- ckfree((char *) dataPtr);
+ }
+ ckfree(dataPtr);
}
/*
@@ -3441,11 +3460,8 @@ GetTableEncoding(
EscapeEncodingData *dataPtr,/* Contains names of encodings. */
int state) /* Index in dataPtr of desired Encoding. */
{
- EscapeSubTable *subTablePtr;
- Encoding *encodingPtr;
-
- subTablePtr = &dataPtr->subTables[state];
- encodingPtr = subTablePtr->encodingPtr;
+ EscapeSubTable *subTablePtr = &dataPtr->subTables[state];
+ Encoding *encodingPtr = subTablePtr->encodingPtr;
if (encodingPtr == NULL) {
encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
@@ -3480,7 +3496,7 @@ GetTableEncoding(
static size_t
unilen(
- CONST char *src)
+ const char *src)
{
unsigned short *p;
@@ -3520,43 +3536,43 @@ InitializeEncodingSearchPath(
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
- char *bytes;
+ const char *bytes;
int i, numDirs, numBytes;
- Tcl_Obj *libPath, *encodingObj, *searchPath;
+ Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
- TclNewObj(searchPath);
+ TclNewObj(searchPathObj);
Tcl_IncrRefCount(encodingObj);
- Tcl_IncrRefCount(searchPath);
- libPath = TclGetLibraryPath();
- Tcl_IncrRefCount(libPath);
- Tcl_ListObjLength(NULL, libPath, &numDirs);
+ Tcl_IncrRefCount(searchPathObj);
+ libPathObj = TclGetLibraryPath();
+ Tcl_IncrRefCount(libPathObj);
+ Tcl_ListObjLength(NULL, libPathObj, &numDirs);
for (i = 0; i < numDirs; i++) {
- Tcl_Obj *directory, *path;
+ Tcl_Obj *directoryObj, *pathObj;
Tcl_StatBuf stat;
- Tcl_ListObjIndex(NULL, libPath, i, &directory);
- path = Tcl_FSJoinToPath(directory, 1, &encodingObj);
- Tcl_IncrRefCount(path);
- if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) {
- Tcl_ListObjAppendElement(NULL, searchPath, path);
+ Tcl_ListObjIndex(NULL, libPathObj, i, &directoryObj);
+ pathObj = Tcl_FSJoinToPath(directoryObj, 1, &encodingObj);
+ Tcl_IncrRefCount(pathObj);
+ if ((0 == Tcl_FSStat(pathObj, &stat)) && S_ISDIR(stat.st_mode)) {
+ Tcl_ListObjAppendElement(NULL, searchPathObj, pathObj);
}
- Tcl_DecrRefCount(path);
+ Tcl_DecrRefCount(pathObj);
}
- Tcl_DecrRefCount(libPath);
+ Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = Tcl_GetStringFromObj(searchPath, &numBytes);
+ bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
- *valuePtr = ckalloc((unsigned int) numBytes + 1);
+ *valuePtr = ckalloc(numBytes + 1);
memcpy(*valuePtr, bytes, (size_t) numBytes + 1);
- Tcl_DecrRefCount(searchPath);
+ Tcl_DecrRefCount(searchPathObj);
}
/*
@@ -3566,4 +3582,3 @@ InitializeEncodingSearchPath(
* fill-column: 78
* End:
*/
-
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
new file mode 100644
index 0000000..1c7b41d
--- /dev/null
+++ b/generic/tclEnsemble.c
@@ -0,0 +1,2969 @@
+/*
+ * tclEnsemble.c --
+ *
+ * Contains support for ensembles (see TIP#112), which provide simple
+ * mechanism for creating composite commands on top of namespaces.
+ *
+ * Copyright (c) 2005-2010 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"
+
+/*
+ * Declarations for functions local to this file:
+ */
+
+static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
+ EnsembleConfig *ensemblePtr, int objc,
+ Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
+static int NsEnsembleImplementationCmd(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int NsEnsembleImplementationCmdNR(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
+static int NsEnsembleStringOrder(const void *strPtr1,
+ const void *strPtr2);
+static void DeleteEnsembleConfig(ClientData clientData);
+static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
+ EnsembleConfig *ensemblePtr,
+ const char *subcmdName, Tcl_Obj *prefixObjPtr);
+static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
+static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
+static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
+
+/*
+ * The lists of subcommands and options for the [namespace ensemble] command.
+ */
+
+static const char *const ensembleSubcommands[] = {
+ "configure", "create", "exists", NULL
+};
+enum EnsSubcmds {
+ ENS_CONFIG, ENS_CREATE, ENS_EXISTS
+};
+
+static const char *const ensembleCreateOptions[] = {
+ "-command", "-map", "-parameters", "-prefixes", "-subcommands",
+ "-unknown", NULL
+};
+enum EnsCreateOpts {
+ CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
+};
+
+static const char *const ensembleConfigOptions[] = {
+ "-map", "-namespace", "-parameters", "-prefixes", "-subcommands",
+ "-unknown", NULL
+};
+enum EnsConfigOpts {
+ CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS,
+ CONF_UNKNOWN
+};
+
+/*
+ * This structure defines a Tcl object type that contains a reference to an
+ * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
+ * to cache the mapping between the subcommand itself and the real command
+ * that implements it.
+ */
+
+const Tcl_ObjType tclEnsembleCmdType = {
+ "ensembleCommand", /* the type's name */
+ FreeEnsembleCmdRep, /* freeIntRepProc */
+ DupEnsembleCmdRep, /* dupIntRepProc */
+ StringOfEnsembleCmdRep, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNamespaceEnsembleCmd --
+ *
+ * Invoked to implement the "namespace ensemble" command that creates and
+ * manipulates ensembles built on top of namespaces. Handles the
+ * following syntax:
+ *
+ * namespace ensemble name ?dictionary?
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * Creates the ensemble for the namespace if one did not previously
+ * exist. Alternatively, alters the way that the ensemble's subcommand =>
+ * implementation prefix is configured.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNamespaceEnsembleCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Namespace *namespacePtr;
+ Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ Tcl_Command token;
+ Tcl_DictSearch search;
+ Tcl_Obj *listObj;
+ int index, done;
+
+ if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_AppendResult(interp,
+ "tried to manipulate ensemble of deleted namespace",
+ NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
+ "subcommand", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum EnsSubcmds) index) {
+ case ENS_CREATE: {
+ const char *name;
+ int len, allocatedMapFlag = 0;
+ /*
+ * Defaults
+ */
+ Tcl_Obj *subcmdObj = NULL;
+ Tcl_Obj *mapObj = NULL;
+ int permitPrefix = 1;
+ Tcl_Obj *unknownObj = NULL;
+ Tcl_Obj *paramObj = NULL;
+
+ /*
+ * Check that we've got option-value pairs... [Bug 1558654]
+ */
+
+ if (objc & 1) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
+ return TCL_ERROR;
+ }
+ objv += 2;
+ objc -= 2;
+
+ /*
+ * Work out what name to use for the command to create. If supplied,
+ * it is either fully specified or relative to the current namespace.
+ * If not supplied, it is exactly the name of the current namespace.
+ */
+
+ name = nsPtr->fullName;
+
+ /*
+ * Parse the option list, applying type checks as we go. Note that we
+ * are not incrementing any reference counts in the objects at this
+ * stage, so the presence of an option multiple times won't cause any
+ * memory leaks.
+ */
+
+ for (; objc>1 ; objc-=2,objv+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
+ "option", 0, &index) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsCreateOpts) index) {
+ case CRT_CMD:
+ name = TclGetString(objv[1]);
+ continue;
+ case CRT_SUBCMDS:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CRT_PARAM:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ paramObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CRT_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;
+
+ /*
+ * Verify that the map is sensible.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdWordsObj, &listObj, &done) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ Tcl_Obj **listv;
+ const char *cmd;
+
+ if (TclListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (len < 1) {
+ Tcl_SetResult(interp,
+ "ensemble subcommand implementations "
+ "must be non-empty lists", TCL_STATIC);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_NewListObj(len, listv);
+ Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
+
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
+ newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+ } while (!done);
+
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CRT_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ continue;
+ case CRT_UNKNOWN:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ /*
+ * Create the ensemble. Note that this might delete another ensemble
+ * linked to the same namespace, so we must be careful. However, we
+ * should be OK because we only link the namespace into the list once
+ * we've created it (and after any deletions have occurred.)
+ */
+
+ token = Tcl_CreateEnsemble(interp, name, NULL,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
+ Tcl_SetEnsembleMappingDict(interp, token, mapObj);
+ Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
+ Tcl_SetEnsembleParameterList(interp, token, paramObj);
+
+ /*
+ * Tricky! Must ensure that the result is not shared (command delete
+ * traces could have corrupted the pristine object that we started
+ * with). [Snit test rename-1.5]
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
+ return TCL_OK;
+ }
+
+ case ENS_EXISTS:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
+ return TCL_OK;
+
+ case ENS_CONFIG:
+ if (objc < 3 || (objc != 4 && !(objc & 1))) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "cmdname ?-option value ...? ?arg ...?");
+ return TCL_ERROR;
+ }
+ token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
+ if (token == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 4) {
+ Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
+
+ if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_PARAM:
+ Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_MAP:
+ Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_NAMESPACE:
+ namespacePtr = NULL; /* silence gcc 4 warning */
+ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
+ Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName,
+ TCL_VOLATILE);
+ break;
+ case CONF_PREFIX: {
+ int flags = 0; /* silence gcc 4 warning */
+
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
+ break;
+ }
+ case CONF_UNKNOWN:
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ }
+ } else if (objc == 3) {
+ /*
+ * Produce list of all information.
+ */
+
+ Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
+ int flags = 0; /* silence gcc 4 warning */
+
+ TclNewObj(resultObj);
+
+ /* -map option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
+ Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -namespace option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
+ -1));
+ namespacePtr = NULL; /* silence gcc 4 warning */
+ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName,
+ -1));
+
+ /* -parameters option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
+ Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -prefix option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
+
+ /* -subcommands option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
+ Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -unknown option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ Tcl_SetObjResult(interp, resultObj);
+ } else {
+ int len, allocatedMapFlag = 0;
+ Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
+ *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
+ int permitPrefix, flags = 0; /* silence gcc 4 warning */
+
+ Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
+ Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
+ Tcl_GetEnsembleParameterList(NULL, token, &paramObj);
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
+
+ objv += 3;
+ objc -= 3;
+
+ /*
+ * Parse the option list, applying type checks as we go. Note that
+ * we are not incrementing any reference counts in the objects at
+ * this stage, so the presence of an option multiple times won't
+ * cause any memory leaks.
+ */
+
+ for (; objc>0 ; objc-=2,objv+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions,
+ "option", 0, &index) != TCL_OK) {
+ freeMapAndError:
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CONF_PARAM:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ paramObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CONF_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
+ const char *cmd;
+
+ /*
+ * Verify that the map is sensible.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdWordsObj, &listObj, &done) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ if (TclListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
+ if (len < 1) {
+ Tcl_SetResult(interp,
+ "ensemble subcommand implementations "
+ "must be non-empty lists", TCL_STATIC);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
+ Tcl_Obj *newCmd =
+ Tcl_NewStringObj(nsPtr->fullName, -1);
+
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
+ newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+ &done);
+ } while (!done);
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CONF_NAMESPACE:
+ Tcl_AppendResult(interp, "option -namespace is read-only",
+ NULL);
+ goto freeMapAndError;
+ case CONF_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ continue;
+ case CONF_UNKNOWN:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ /*
+ * Update the namespace now that we've finished the parsing stage.
+ */
+
+ flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
+ : flags&~TCL_ENSEMBLE_PREFIX);
+ Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
+ Tcl_SetEnsembleMappingDict(interp, token, mapObj);
+ Tcl_SetEnsembleParameterList(interp, token, paramObj);
+ Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
+ Tcl_SetEnsembleFlags(interp, token, flags);
+ }
+ return TCL_OK;
+
+ default:
+ Tcl_Panic("unexpected ensemble command");
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEnsemble --
+ *
+ * Create a simple ensemble attached to the given namespace.
+ *
+ * Results:
+ * The token for the command created.
+ *
+ * Side effects:
+ * The ensemble is created and marked for compilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateEnsemble(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *namespacePtr,
+ int flags)
+{
+ Namespace *nsPtr = (Namespace *) namespacePtr;
+ EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ Tcl_Obj *nameObj = NULL;
+
+ if (nsPtr == NULL) {
+ nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ /*
+ * Make the name of the ensemble into a fully qualified name. This might
+ * allocate a temporary object.
+ */
+
+ if (!(name[0] == ':' && name[1] == ':')) {
+ nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
+ if (nsPtr->parentPtr == NULL) {
+ Tcl_AppendStringsToObj(nameObj, name, NULL);
+ } else {
+ Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
+ }
+ Tcl_IncrRefCount(nameObj);
+ name = TclGetString(nameObj);
+ }
+
+ ensemblePtr->nsPtr = nsPtr;
+ ensemblePtr->epoch = 0;
+ Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
+ ensemblePtr->subcommandArrayPtr = NULL;
+ ensemblePtr->subcmdList = NULL;
+ ensemblePtr->subcommandDict = NULL;
+ ensemblePtr->flags = flags;
+ ensemblePtr->numParameters = 0;
+ ensemblePtr->parameterList = NULL;
+ ensemblePtr->unknownHandler = NULL;
+ ensemblePtr->token = Tcl_NRCreateCommand(interp, name,
+ NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
+ ensemblePtr, DeleteEnsembleConfig);
+ ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ nsPtr->exportLookupEpoch++;
+
+ if (flags & ENSEMBLE_COMPILE) {
+ ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
+ }
+
+ if (nameObj != NULL) {
+ TclDecrRefCount(nameObj);
+ }
+ return ensemblePtr->token;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleSubcommandList --
+ *
+ * Set the subcommand list for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the subcommand list - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleSubcommandList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *subcmdList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ return TCL_ERROR;
+ }
+ if (subcmdList != NULL) {
+ int length;
+
+ if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ subcmdList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->subcmdList;
+ ensemblePtr->subcmdList = subcmdList;
+ if (subcmdList != NULL) {
+ Tcl_IncrRefCount(subcmdList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleParameterList --
+ *
+ * Set the parameter list for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the parameter list - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleParameterList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *paramList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+ int length;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ return TCL_ERROR;
+ }
+ if (paramList == NULL) {
+ length = 0;
+ } else {
+ if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ paramList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->parameterList;
+ ensemblePtr->parameterList = paramList;
+ if (paramList != NULL) {
+ Tcl_IncrRefCount(paramList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+ ensemblePtr->numParameters = length;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleMappingDict --
+ *
+ * Set the mapping dictionary for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the mapping - if non-NULL - is not a dict).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleMappingDict(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *mapDict)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldDict;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ return TCL_ERROR;
+ }
+ if (mapDict != NULL) {
+ int size, done;
+ Tcl_DictSearch search;
+ Tcl_Obj *valuePtr;
+
+ if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
+ !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
+ Tcl_Obj *cmdObjPtr;
+ const char *bytes;
+
+ if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ bytes = TclGetString(cmdObjPtr);
+ if (bytes[0] != ':' || bytes[1] != ':') {
+ Tcl_AppendResult(interp,
+ "ensemble target is not a fully-qualified command",
+ NULL);
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ }
+
+ if (size < 1) {
+ mapDict = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldDict = ensemblePtr->subcommandDict;
+ ensemblePtr->subcommandDict = mapDict;
+ if (mapDict != NULL) {
+ Tcl_IncrRefCount(mapDict);
+ }
+ if (oldDict != NULL) {
+ TclDecrRefCount(oldDict);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleUnknownHandler --
+ *
+ * Set the unknown handler for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the unknown handler - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleUnknownHandler(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *unknownList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ return TCL_ERROR;
+ }
+ if (unknownList != NULL) {
+ int length;
+
+ if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ unknownList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->unknownHandler;
+ ensemblePtr->unknownHandler = unknownList;
+ if (unknownList != NULL) {
+ Tcl_IncrRefCount(unknownList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleFlags --
+ *
+ * Set the flags for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleFlags(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ int flags)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ int wasCompiled;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
+
+ /*
+ * This API refuses to set the ENSEMBLE_DEAD flag...
+ */
+
+ ensemblePtr->flags &= ENSEMBLE_DEAD;
+ ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
+ * compiler function and bump the interpreter's compilation epoch so that
+ * bytecode gets regenerated.
+ */
+
+ if (flags & ENSEMBLE_COMPILE) {
+ if (!wasCompiled) {
+ ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
+ ((Interp *) interp)->compileEpoch++;
+ }
+ } else {
+ if (wasCompiled) {
+ ((Command *) ensemblePtr->token)->compileProc = NULL;
+ ((Interp *) interp)->compileEpoch++;
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleSubcommandList --
+ *
+ * Get the list of subcommands associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The list of subcommands is returned by updating the
+ * variable pointed to by the last parameter (NULL if this is to be
+ * derived from the mapping dictionary or the associated namespace's
+ * exported commands).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleSubcommandList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **subcmdListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *subcmdListPtr = ensemblePtr->subcmdList;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleParameterList --
+ *
+ * Get the list of parameters associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The list of parameters is returned by updating the
+ * variable pointed to by the last parameter (NULL if there are
+ * no parameters).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleParameterList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **paramListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *paramListPtr = ensemblePtr->parameterList;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleMappingDict --
+ *
+ * Get the command mapping dictionary associated with a particular
+ * ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The mapping dict is returned by updating the variable
+ * pointed to by the last parameter (NULL if none is installed).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleMappingDict(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **mapDictPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *mapDictPtr = ensemblePtr->subcommandDict;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleUnknownHandler --
+ *
+ * Get the unknown handler associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The unknown handler is returned by updating the variable
+ * pointed to by the last parameter (NULL if no handler is installed).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleUnknownHandler(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **unknownListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *unknownListPtr = ensemblePtr->unknownHandler;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleFlags --
+ *
+ * Get the flags for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The flags are returned by updating the variable pointed to
+ * by the last parameter.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleFlags(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ int *flagsPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *flagsPtr = ensemblePtr->flags;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleNamespace --
+ *
+ * Get the namespace associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). Namespace is returned by updating the variable pointed to
+ * by the last parameter.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleNamespace(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Namespace **namespacePtrPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindEnsemble --
+ *
+ * Given a command name, get the ensemble token for it, allowing for
+ * [namespace import]s. [Bug 1017022]
+ *
+ * Results:
+ * The token for the ensemble command with the given name, or NULL if the
+ * command either does not exist or is not an ensemble (when an error
+ * message will be written into the interp if thats non-NULL).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_FindEnsemble(
+ Tcl_Interp *interp, /* Where to do the lookup, and where to write
+ * the errors if TCL_LEAVE_ERR_MSG is set in
+ * the flags. */
+ Tcl_Obj *cmdNameObj, /* Name of command to look up. */
+ int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
+ * are probably not useful. */
+{
+ Command *cmdPtr;
+
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
+ if (cmdPtr == NULL) {
+ return NULL;
+ }
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ /*
+ * Reuse existing infrastructure for following import link chains
+ * rather than duplicating it.
+ */
+
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+
+ if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
+ "\" is not an ensemble command", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+ TclGetString(cmdNameObj), NULL);
+ }
+ return NULL;
+ }
+ }
+
+ return (Tcl_Command) cmdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsEnsemble --
+ *
+ * Simple test for ensemble-hood that takes into account imported
+ * ensemble commands as well.
+ *
+ * Results:
+ * Boolean value
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_IsEnsemble(
+ Tcl_Command token)
+{
+ Command *cmdPtr = (Command *) token;
+
+ if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ return 1;
+ }
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ return 0;
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMakeEnsemble --
+ *
+ * Create an ensemble from a table of implementation commands. The
+ * ensemble will be subject to (limited) compilation if any of the
+ * implementation commands are compilable.
+ *
+ * The 'name' parameter may be a single command name or a list if
+ * creating an ensemble subcommand (see the binary implementation).
+ *
+ * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
+ * top-level ensemble commands.
+ *
+ * Results:
+ * Handle for the new ensemble, or NULL on failure.
+ *
+ * Side effects:
+ * May advance the bytecode compilation epoch.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclMakeEnsemble(
+ Tcl_Interp *interp,
+ const char *name, /* The ensemble name (as explained above) */
+ const EnsembleImplMap map[]) /* The subcommands to create */
+{
+ Tcl_Command ensemble;
+ Tcl_Namespace *ns;
+ Tcl_DString buf, hiddenBuf;
+ const char **nameParts = NULL;
+ const char *cmdName = NULL;
+ int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
+
+ /*
+ * Construct the path for the ensemble namespace and create it.
+ */
+
+ Tcl_DStringInit(&buf);
+ Tcl_DStringInit(&hiddenBuf);
+ Tcl_DStringAppend(&hiddenBuf, "tcl:", -1);
+ Tcl_DStringAppend(&hiddenBuf, name, -1);
+ Tcl_DStringAppend(&hiddenBuf, ":", -1);
+ hiddenLen = Tcl_DStringLength(&hiddenBuf);
+ if (name[0] == ':' && name[1] == ':') {
+ /*
+ * An absolute name, so use it directly.
+ */
+
+ cmdName = name;
+ Tcl_DStringAppend(&buf, name, -1);
+ ensembleFlags = TCL_ENSEMBLE_PREFIX;
+ } else {
+ /*
+ * Not an absolute name, so do munging of it. Note that this treats a
+ * multi-word list differently to a single word.
+ */
+
+ Tcl_DStringAppend(&buf, "::tcl", -1);
+
+ if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
+ Tcl_Panic("invalid ensemble name '%s'", name);
+ }
+
+ for (i = 0; i < nameCount; ++i) {
+ Tcl_DStringAppend(&buf, "::", 2);
+ Tcl_DStringAppend(&buf, nameParts[i], -1);
+ }
+ }
+
+ ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
+ TCL_CREATE_NS_IF_UNKNOWN);
+ if (!ns) {
+ Tcl_Panic("unable to find or create %s namespace!",
+ Tcl_DStringValue(&buf));
+ }
+
+ /*
+ * Create the named ensemble in the correct namespace
+ */
+
+ if (cmdName == NULL) {
+ if (nameCount == 1) {
+ ensembleFlags = TCL_ENSEMBLE_PREFIX;
+ cmdName = Tcl_DStringValue(&buf) + 5;
+ } else {
+ ns = ns->parentPtr;
+ cmdName = nameParts[nameCount - 1];
+ }
+ }
+ ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
+
+ /*
+ * Create the ensemble mapping dictionary and the ensemble command procs.
+ */
+
+ if (ensemble != NULL) {
+ Tcl_Obj *mapDict, *fromObj, *toObj;
+ Command *cmdPtr;
+
+ Tcl_DStringAppend(&buf, "::", 2);
+ TclNewObj(mapDict);
+ for (i=0 ; map[i].name != NULL ; i++) {
+ fromObj = Tcl_NewStringObj(map[i].name, -1);
+ TclNewStringObj(toObj, Tcl_DStringValue(&buf),
+ Tcl_DStringLength(&buf));
+ Tcl_AppendToObj(toObj, map[i].name, -1);
+ Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
+
+ if (map[i].proc || map[i].nreProc) {
+ /*
+ * If the command is unsafe, hide it when we're in a safe
+ * interpreter. The code to do this is really hokey! It also
+ * doesn't work properly yet; this function is always
+ * currently called before the safe-interp flag is set so the
+ * Tcl_IsSafe check fails.
+ */
+
+ if (map[i].unsafe && Tcl_IsSafe(interp)) {
+ cmdPtr = (Command *)
+ Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
+ map[i].nreProc, map[i].clientData, NULL);
+ Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
+ if (Tcl_HideCommand(interp, "___tmp",
+ Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
+ Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ } else {
+ /*
+ * Not hidden, so just create it. Yay!
+ */
+
+ cmdPtr = (Command *)
+ Tcl_NRCreateCommand(interp, TclGetString(toObj),
+ map[i].proc, map[i].nreProc, map[i].clientData,
+ NULL);
+ }
+ cmdPtr->compileProc = map[i].compileProc;
+ if (map[i].compileProc != NULL) {
+ ensembleFlags |= ENSEMBLE_COMPILE;
+ }
+ }
+ }
+ Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
+ if (ensembleFlags & ENSEMBLE_COMPILE) {
+ Tcl_SetEnsembleFlags(interp, ensemble, ensembleFlags);
+ }
+ }
+
+ Tcl_DStringFree(&buf);
+ Tcl_DStringFree(&hiddenBuf);
+ if (nameParts != NULL) {
+ Tcl_Free((char *) nameParts);
+ }
+ return ensemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleImplementationCmd --
+ *
+ * Implements an ensemble of commands (being those exported by a
+ * namespace other than the global namespace) as a command with the same
+ * (short) name as the namespace in the parent namespace.
+ *
+ * Results:
+ * A standard Tcl result code. Will be TCL_ERROR if the command is not an
+ * unambiguous prefix of any command exported by the ensemble's
+ * namespace.
+ *
+ * Side effects:
+ * Depends on the command within the namespace that gets executed. If the
+ * ensemble itself returns TCL_ERROR, a descriptive error message will be
+ * placed in the interpreter's result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleImplementationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
+ clientData, objc, objv);
+}
+
+static int
+NsEnsembleImplementationCmdNR(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ EnsembleConfig *ensemblePtr = clientData;
+ /* The ensemble itself. */
+ Tcl_Obj *prefixObj; /* An object containing the prefix words of
+ * the command that implements the
+ * subcommand. */
+ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
+ * specified but not yet cached command
+ * names. */
+ int reparseCount = 0; /* Number of reparses. */
+
+ /*
+ * Must recheck objc, since numParameters might have changed. Cf. test
+ * namespace-53.9.
+ */
+
+ restartEnsembleParse:
+ if (objc < 2 + ensemblePtr->numParameters) {
+ /*
+ * We don't have a subcommand argument. Make error message.
+ */
+
+ Tcl_DString buf; /* Message being built */
+ Tcl_Obj **elemPtrs; /* Parameter names */
+ int len; /* Number of parameters to append */
+
+ Tcl_DStringInit(&buf);
+ if (ensemblePtr->parameterList == NULL) {
+ len = 0;
+ } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList,
+ &len, &elemPtrs) != TCL_OK) {
+ Tcl_Panic("List of ensemble parameters is not a list");
+ }
+ for (; len>0; len--,elemPtrs++) {
+ Tcl_DStringAppend(&buf, Tcl_GetString(*elemPtrs), -1);
+ Tcl_DStringAppend(&buf, " ", -1);
+ }
+ Tcl_DStringAppend(&buf, "subcommand ?arg ...?", -1);
+ Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
+ Tcl_DStringFree(&buf);
+
+ return TCL_ERROR;
+ }
+
+ if (ensemblePtr->nsPtr->flags & NS_DYING) {
+ /*
+ * Don't know how we got here, but make things give up quickly.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_AppendResult(interp,
+ "ensemble activated for deleted namespace", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Determine if the table of subcommands is right. If so, we can just look
+ * up in there and go straight to dispatch.
+ */
+
+ if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
+ /*
+ * Table of subcommands is still valid; therefore there might be a
+ * valid cache of discovered information which we can reuse. Do the
+ * check here, and if we're still valid, we can jump straight to the
+ * part where we do the invocation of the subcommand.
+ */
+
+ if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
+ EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
+ ->internalRep.otherValuePtr;
+
+ if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
+ ensembleCmd->epoch == ensemblePtr->epoch &&
+ ensembleCmd->token == ensemblePtr->token) {
+ prefixObj = ensembleCmd->realPrefixObj;
+ Tcl_IncrRefCount(prefixObj);
+ goto runResultingSubcommand;
+ }
+ }
+ } else {
+ BuildEnsembleConfig(ensemblePtr);
+ ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
+ }
+
+ /*
+ * Look in the hashtable for the subcommand name; this is the fastest way
+ * of all if there is no cache in operation.
+ */
+
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
+ TclGetString(objv[1 + ensemblePtr->numParameters]));
+ if (hPtr != NULL) {
+ char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
+
+ prefixObj = Tcl_GetHashValue(hPtr);
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
+ ensemblePtr, fullName, prefixObj);
+ } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
+ /*
+ * Could not map, no prefixing, go to unknown/error handling.
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ } else {
+ /*
+ * If we've not already confirmed the command with the hash as part of
+ * building our export table, we need to scan the sorted array for
+ * matches.
+ */
+
+ const char *subcmdName; /* Name of the subcommand, or unique prefix of
+ * it (will be an error for a non-unique
+ * prefix). */
+ char *fullName = NULL; /* Full name of the subcommand. */
+ int stringLength, i;
+ int tableLength = ensemblePtr->subcommandTable.numEntries;
+
+ subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]);
+ stringLength = objv[1 + ensemblePtr->numParameters]->length;
+ for (i=0 ; i<tableLength ; i++) {
+ register int cmp = strncmp(subcmdName,
+ ensemblePtr->subcommandArrayPtr[i],
+ (unsigned) stringLength);
+
+ if (cmp == 0) {
+ if (fullName != NULL) {
+ /*
+ * Since there's never the exact-match case to worry about
+ * (hash search filters this), getting here indicates that
+ * our subcommand is an ambiguous prefix of (at least) two
+ * exported subcommands, which is an error case.
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ }
+ fullName = ensemblePtr->subcommandArrayPtr[i];
+ } else if (cmp < 0) {
+ /*
+ * Because we are searching a sorted table, we can now stop
+ * searching because we have gone past anything that could
+ * possibly match.
+ */
+
+ break;
+ }
+ }
+ if (fullName == NULL) {
+ /*
+ * The subcommand is not a prefix of anything, so bail out!
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ }
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
+ if (hPtr == NULL) {
+ Tcl_Panic("full name %s not found in supposedly synchronized hash",
+ fullName);
+ }
+ prefixObj = Tcl_GetHashValue(hPtr);
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
+ ensemblePtr, fullName, prefixObj);
+ }
+
+ Tcl_IncrRefCount(prefixObj);
+ runResultingSubcommand:
+
+ /*
+ * Do the real work of execution of the subcommand by building an array of
+ * objects (note that this is potentially not the same length as the
+ * number of arguments to this ensemble command), populating it and then
+ * feeding it back through the main command-lookup engine. In theory, we
+ * could look up the command in the namespace ourselves, as we already
+ * have the namespace in which it is guaranteed to exist,
+ *
+ * ((Q: That's not true if the -map option is used, is it?))
+ *
+ * but we don't do that (the cacheing of the command object used should
+ * help with that.)
+ */
+
+ {
+ Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
+ * target command prefix. */
+ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
+ * Will be freed by the dispatch engine. */
+ int prefixObjc, copyObjc;
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Get the prefix that we're rewriting to. To do this we need to
+ * ensure that the internal representation of the list does not change
+ * so that we can safely keep the internal representations of the
+ * elements in the list.
+ *
+ * TODO: Use conventional list operations to make this code sane!
+ */
+
+ TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
+
+ copyObjc = objc - 2 + prefixObjc;
+ copyPtr = Tcl_NewListObj(copyObjc, NULL);
+ if (copyObjc > 0) {
+ register Tcl_Obj **copyObjv;
+ /* Space used to construct the list of
+ * arguments to pass to the command that
+ * implements the ensemble subcommand. */
+ register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+ register int i;
+
+ listRepPtr->elemCount = copyObjc;
+ copyObjv = &listRepPtr->elements;
+ memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
+ memcpy(copyObjv+prefixObjc, objv+1,
+ sizeof(Tcl_Obj *) * ensemblePtr->numParameters);
+ memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters,
+ objv+ensemblePtr->numParameters+2,
+ sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2));
+
+ for (i=0; i < copyObjc; i++) {
+ Tcl_IncrRefCount(copyObjv[i]);
+ }
+ }
+ TclDecrRefCount(prefixObj);
+
+ /*
+ * Record what arguments the script sent in so that things like
+ * Tcl_WrongNumArgs can give the correct error message. Parameters
+ * count both as inserted and removed arguments.
+ */
+
+#if 0
+ if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+#else
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs =
+ 2 + ensemblePtr->numParameters;
+ iPtr->ensembleRewrite.numInsertedObjs =
+ prefixObjc + ensemblePtr->numParameters;
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
+ NULL);
+ } else {
+ register int ni = 2 + ensemblePtr->numParameters
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ /* Position in objv of new front of insertion
+ * relative to old one. */
+ if (ni > 0) {
+ iPtr->ensembleRewrite.numRemovedObjs += ni;
+ iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
+ }
+ }
+#endif
+
+ /*
+ * Hand off to the target command.
+ */
+
+ iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
+ }
+
+ unknownOrAmbiguousSubcommand:
+ /*
+ * Have not been able to match the subcommand asked for with a real
+ * subcommand that we export. See whether a handler has been registered
+ * for dealing with this situation. Will only call (at most) once for any
+ * particular ensemble invocation.
+ */
+
+ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
+ switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv,
+ &prefixObj)) {
+ case TCL_OK:
+ goto runResultingSubcommand;
+ case TCL_ERROR:
+ return TCL_ERROR;
+ case TCL_CONTINUE:
+ goto restartEnsembleParse;
+ }
+ }
+
+ /*
+ * We cannot determine what subcommand to hand off to, so generate a
+ * (standard) failure message. Note the one odd case compared with
+ * standard ensemble-like command, which is where a namespace has no
+ * exported commands at all...
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+ TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ if (ensemblePtr->subcommandTable.numEntries == 0) {
+ Tcl_AppendResult(interp, "unknown subcommand \"",
+ TclGetString(objv[1+ensemblePtr->numParameters]),
+ "\": namespace ", ensemblePtr->nsPtr->fullName,
+ " does not export any commands", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
+ TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, "unknown ",
+ (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
+ "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]),
+ "\": must be ", NULL);
+ if (ensemblePtr->subcommandTable.numEntries == 1) {
+ Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
+ } else {
+ int i;
+
+ for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
+ Tcl_AppendResult(interp,
+ ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
+ }
+ Tcl_AppendResult(interp, "or ",
+ ensemblePtr->subcommandArrayPtr[i], NULL);
+ }
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
+ TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ return TCL_ERROR;
+}
+
+int
+TclClearRootEnsemble(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclResetRewriteEnsemble(interp, 1);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitRewriteEnsemble --
+ *
+ * Applies a rewrite of arguments so that an ensemble subcommand will
+ * report error messages correctly for the overall command.
+ *
+ * Results:
+ * Whether this is the first rewrite applied, a value which must be
+ * passed to TclResetRewriteEnsemble when undoing this command's
+ * behaviour.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInitRewriteEnsemble(
+ Tcl_Interp *interp,
+ int numRemoved,
+ int numInserted,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
+ iPtr->ensembleRewrite.numInsertedObjs = numInserted;
+ } else {
+ int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+ if (numIns < numRemoved) {
+ iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
+ iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
+ }
+ }
+ return isRootEnsemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResetRewriteEnsemble --
+ *
+ * Removes any rewrites applied to support proper reporting of error
+ * messages used in ensembles. Should be paired with
+ * TclInitRewriteEnsemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclResetRewriteEnsemble(
+ Tcl_Interp *interp,
+ int isRootEnsemble)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = NULL;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * EnsmebleUnknownCallback --
+ *
+ * Helper for the ensemble engine that handles the procesing of unknown
+ * callbacks. See the user documentation of the ensemble unknown handler
+ * for details; this function is only ever called when such a function is
+ * defined, and is only ever called once per ensemble dispatch (i.e. if a
+ * reparse still fails, this isn't called again).
+ *
+ * Results:
+ * TCL_OK - *prefixObjPtr contains the command words to dispatch
+ * to.
+ * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
+ * TCL_ERROR - Something went wrong! Error message in interpreter.
+ *
+ * Side effects:
+ * Calls the Tcl interpreter, so arbitrary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+EnsembleUnknownCallback(
+ Tcl_Interp *interp,
+ EnsembleConfig *ensemblePtr,
+ int objc,
+ Tcl_Obj *const objv[],
+ Tcl_Obj **prefixObjPtr)
+{
+ int paramc, i, result, prefixObjc;
+ Tcl_Obj **paramv, *unknownCmd, *ensObj;
+ char buf[TCL_INTEGER_SPACE];
+
+ /*
+ * Create the unknown command callback to determine what to do.
+ */
+
+ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
+ TclNewObj(ensObj);
+ Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
+ Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
+ for (i=1 ; i<objc ; i++) {
+ Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
+ }
+ TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ Tcl_IncrRefCount(unknownCmd);
+
+ /*
+ * Now call the unknown handler. (We don't bother NRE-enabling this; deep
+ * recursing through unknown handlers is horribly perverse.) Note that it
+ * is always an error for an unknown handler to delete its ensemble; don't
+ * do that!
+ */
+
+ Tcl_Preserve(ensemblePtr);
+ ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ result = Tcl_EvalObjv(interp, paramc, paramv, 0);
+ if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
+ Tcl_SetResult(interp,
+ "unknown subcommand handler deleted its ensemble",
+ TCL_STATIC);
+ result = TCL_ERROR;
+ }
+ Tcl_Release(ensemblePtr);
+
+ /*
+ * If we succeeded, we should either have a list of words that form the
+ * command to be executed, or an empty list. In the empty-list case, the
+ * ensemble is believed to be updated so we should ask the ensemble engine
+ * to reparse the original command.
+ */
+
+ if (result == TCL_OK) {
+ *prefixObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(*prefixObjPtr);
+ TclDecrRefCount(unknownCmd);
+ Tcl_ResetResult(interp);
+
+ /*
+ * Namespace is still there. Check if the result is a valid list. If
+ * it is, and it is non-empty, that list is what we are using as our
+ * replacement.
+ */
+
+ if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
+ TclDecrRefCount(*prefixObjPtr);
+ Tcl_AddErrorInfo(interp, "\n while parsing result of "
+ "ensemble unknown subcommand handler");
+ return TCL_ERROR;
+ }
+ if (prefixObjc > 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * Namespace alive & empty result => reparse.
+ */
+
+ TclDecrRefCount(*prefixObjPtr);
+ return TCL_CONTINUE;
+ }
+
+ /*
+ * Oh no! An exceptional result. Convert to an error.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ if (result != TCL_ERROR) {
+ Tcl_ResetResult(interp);
+ Tcl_SetResult(interp,
+ "unknown subcommand handler returned bad code: ",
+ TCL_STATIC);
+ switch (result) {
+ case TCL_RETURN:
+ Tcl_AppendResult(interp, "return", NULL);
+ break;
+ case TCL_BREAK:
+ Tcl_AppendResult(interp, "break", NULL);
+ break;
+ case TCL_CONTINUE:
+ Tcl_AppendResult(interp, "continue", NULL);
+ break;
+ default:
+ sprintf(buf, "%d", result);
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ Tcl_AddErrorInfo(interp, "\n result of "
+ "ensemble unknown subcommand handler: ");
+ Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ } else {
+ Tcl_AddErrorInfo(interp,
+ "\n (ensemble unknown subcommand handler)");
+ }
+ }
+ TclDecrRefCount(unknownCmd);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeCachedEnsembleCommand --
+ *
+ * Cache what we've computed so far; it's not nice to repeatedly copy
+ * strings about. Note that to do this, we start by deleting any old
+ * representation that there was (though if it was an out of date
+ * ensemble rep, we can skip some of the deallocation process.)
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Alters the internal representation of the first object parameter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MakeCachedEnsembleCommand(
+ Tcl_Obj *objPtr,
+ EnsembleConfig *ensemblePtr,
+ const char *subcommandName,
+ Tcl_Obj *prefixObjPtr)
+{
+ register EnsembleCmdRep *ensembleCmd;
+ int length;
+
+ if (objPtr->typePtr == &tclEnsembleCmdType) {
+ ensembleCmd = objPtr->internalRep.otherValuePtr;
+ Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
+ TclNsDecrRefCount(ensembleCmd->nsPtr);
+ ckfree(ensembleCmd->fullSubcmdName);
+ } else {
+ /*
+ * Kill the old internal rep, and replace it with a brand new one of
+ * our own.
+ */
+
+ TclFreeIntRep(objPtr);
+ ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
+ objPtr->internalRep.otherValuePtr = ensembleCmd;
+ objPtr->typePtr = &tclEnsembleCmdType;
+ }
+
+ /*
+ * Populate the internal rep.
+ */
+
+ ensembleCmd->nsPtr = ensemblePtr->nsPtr;
+ ensembleCmd->epoch = ensemblePtr->epoch;
+ ensembleCmd->token = ensemblePtr->token;
+ ensemblePtr->nsPtr->refCount++;
+ ensembleCmd->realPrefixObj = prefixObjPtr;
+ length = strlen(subcommandName)+1;
+ ensembleCmd->fullSubcmdName = ckalloc(length);
+ memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
+ Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteEnsembleConfig --
+ *
+ * Destroys the data structure used to represent an ensemble. This is
+ * called when the ensemble's command is deleted (which happens
+ * automatically if the ensemble's namespace is deleted.) Maintainers
+ * should note that ensembles should be deleted by deleting their
+ * commands.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is (eventually) deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteEnsembleConfig(
+ ClientData clientData)
+{
+ EnsembleConfig *ensemblePtr = clientData;
+ Namespace *nsPtr = ensemblePtr->nsPtr;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hEnt;
+
+ /*
+ * Unlink from the ensemble chain if it has not been marked as having been
+ * done already.
+ */
+
+ if (ensemblePtr->next != ensemblePtr) {
+ EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
+
+ if (ensPtr == ensemblePtr) {
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
+ } else {
+ while (ensPtr != NULL) {
+ if (ensPtr->next == ensemblePtr) {
+ ensPtr->next = ensemblePtr->next;
+ break;
+ }
+ ensPtr = ensPtr->next;
+ }
+ }
+ }
+
+ /*
+ * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
+ * whether disaster happened anyway.
+ */
+
+ ensemblePtr->flags |= ENSEMBLE_DEAD;
+
+ /*
+ * Kill the pointer-containing fields.
+ */
+
+ if (ensemblePtr->subcommandTable.numEntries != 0) {
+ ckfree(ensemblePtr->subcommandArrayPtr);
+ }
+ hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
+ while (hEnt != NULL) {
+ Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt);
+
+ Tcl_DecrRefCount(prefixObj);
+ hEnt = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcmdList);
+ }
+ if (ensemblePtr->parameterList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->parameterList);
+ }
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcommandDict);
+ }
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->unknownHandler);
+ }
+
+ /*
+ * Arrange for the structure to be reclaimed. Note that this is complex
+ * because we have to make sure that we can react sensibly when an
+ * ensemble is deleted during the process of initialising the ensemble
+ * (especially the unknown callback.)
+ */
+
+ Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildEnsembleConfig --
+ *
+ * Create the internal data structures that describe how an ensemble
+ * looks, being a hash mapping from the full command name to the Tcl list
+ * that describes the implementation prefix words, and a sorted array of
+ * all the full command names to allow for reasonably efficient
+ * unambiguous prefix handling.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Reallocates and rebuilds the hash table and array stored at the
+ * ensemblePtr argument. For large ensembles or large namespaces, this is
+ * a potentially expensive operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BuildEnsembleConfig(
+ EnsembleConfig *ensemblePtr)
+{
+ Tcl_HashSearch search; /* Used for scanning the set of commands in
+ * the namespace that backs up this
+ * ensemble. */
+ int i, j, isNew;
+ Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
+ Tcl_HashEntry *hPtr;
+
+ if (hash->numEntries != 0) {
+ /*
+ * Remove pre-existing table.
+ */
+
+ ckfree(ensemblePtr->subcommandArrayPtr);
+ hPtr = Tcl_FirstHashEntry(hash, &search);
+ while (hPtr != NULL) {
+ Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
+
+ Tcl_DecrRefCount(prefixObj);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(hash);
+ Tcl_InitHashTable(hash, TCL_STRING_KEYS);
+ }
+
+ /*
+ * See if we've got an export list. If so, we will only export exactly
+ * those commands, which may be either implemented by the prefix in the
+ * subcommandDict or mapped directly onto the namespace's commands.
+ */
+
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
+ int subcmdc;
+
+ TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
+ &subcmdv);
+ for (i=0 ; i<subcmdc ; i++) {
+ const char *name = TclGetString(subcmdv[i]);
+
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+
+ /*
+ * Skip non-unique cases.
+ */
+
+ if (!isNew) {
+ continue;
+ }
+
+ /*
+ * Look in our dictionary (if present) for the command.
+ */
+
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
+ &target);
+ if (target != NULL) {
+ Tcl_SetHashValue(hPtr, target);
+ Tcl_IncrRefCount(target);
+ continue;
+ }
+ }
+
+ /*
+ * Not there, so map onto the namespace. Note in this case that we
+ * do not guarantee that the command is actually there; that is
+ * the programmer's responsibility (or [::unknown] of course).
+ */
+
+ cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
+ if (ensemblePtr->nsPtr->parentPtr != NULL) {
+ Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
+ } else {
+ Tcl_AppendStringsToObj(cmdObj, name, NULL);
+ }
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ } else if (ensemblePtr->subcommandDict != NULL) {
+ /*
+ * No subcmd list, but we do have a mapping dictionary so we should
+ * use the keys of that. Convert the dictionary's contents into the
+ * form required for the ensemble's internal hashtable.
+ */
+
+ Tcl_DictSearch dictSearch;
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
+ &keyObj, &valueObj, &done);
+ while (!done) {
+ const char *name = TclGetString(keyObj);
+
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ Tcl_SetHashValue(hPtr, valueObj);
+ Tcl_IncrRefCount(valueObj);
+ Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
+ }
+ } else {
+ /*
+ * Discover what commands are actually exported by the namespace.
+ * What we have is an array of patterns and a hash table whose keys
+ * are the command names exported by the namespace (the contents do
+ * not matter here.) We must find out what commands are actually
+ * exported by filtering each command in the namespace against each of
+ * the patterns in the export list. Note that we use an intermediate
+ * hash table to make memory management easier, and because that makes
+ * exact matching far easier too.
+ *
+ * Suggestion for future enhancement: compute the unique prefixes and
+ * place them in the hash too, which should make for even faster
+ * matching.
+ */
+
+ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
+ for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
+ char *nsCmdName = /* Name of command in namespace. */
+ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
+
+ for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
+ if (Tcl_StringMatch(nsCmdName,
+ ensemblePtr->nsPtr->exportArrayPtr[i])) {
+ hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
+
+ /*
+ * Remember, hash entries have a full reference to the
+ * substituted part of the command (as a list) as their
+ * content!
+ */
+
+ if (isNew) {
+ Tcl_Obj *cmdObj, *cmdPrefixObj;
+
+ TclNewObj(cmdObj);
+ Tcl_AppendStringsToObj(cmdObj,
+ ensemblePtr->nsPtr->fullName,
+ (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
+ nsCmdName, NULL);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ break;
+ }
+ }
+ }
+ }
+
+ if (hash->numEntries == 0) {
+ ensemblePtr->subcommandArrayPtr = NULL;
+ return;
+ }
+
+ /*
+ * Create a sorted array of all subcommands in the ensemble; hash tables
+ * are all very well for a quick look for an exact match, but they can't
+ * determine things like whether a string is a prefix of another (not
+ * without lots of preparation anyway) and they're no good for when we're
+ * generating the error message either.
+ *
+ * We do this by filling an array with the names (we use the hash keys
+ * directly to save a copy, since any time we change the array we change
+ * the hash too, and vice versa) and running quicksort over the array.
+ */
+
+ ensemblePtr->subcommandArrayPtr =
+ ckalloc(sizeof(char *) * hash->numEntries);
+
+ /*
+ * Fill array from both ends as this makes us less likely to end up with
+ * performance problems in qsort(), which is good. Note that doing this
+ * makes this code much more opaque, but the naive alternatve:
+ *
+ * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
+ * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
+ * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
+ * }
+ *
+ * can produce long runs of precisely ordered table entries when the
+ * commands in the namespace are declared in a sorted fashion (an ordering
+ * some people like) and the hashing functions (or the command names
+ * themselves) are fairly unfortunate. By filling from both ends, it
+ * requires active malice (and probably a debugger) to get qsort() to have
+ * awful runtime behaviour.
+ */
+
+ i = 0;
+ j = hash->numEntries;
+ hPtr = Tcl_FirstHashEntry(hash, &search);
+ while (hPtr != NULL) {
+ ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ if (hPtr == NULL) {
+ break;
+ }
+ ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ if (hash->numEntries > 1) {
+ qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
+ sizeof(char *), NsEnsembleStringOrder);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleStringOrder --
+ *
+ * Helper function to compare two pointers to two strings for use with
+ * qsort().
+ *
+ * Results:
+ * -1 if the first string is smaller, 1 if the second string is smaller,
+ * and 0 if they are equal.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleStringOrder(
+ const void *strPtr1,
+ const void *strPtr2)
+{
+ return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeEnsembleCmdRep --
+ *
+ * Destroys the internal representation of a Tcl_Obj that has been
+ * holding information about a command in an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is deallocated. If this held the last reference to a
+ * namespace's main structure, that main structure will also be
+ * destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeEnsembleCmdRep(
+ Tcl_Obj *objPtr)
+{
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+
+ Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
+ ckfree(ensembleCmd->fullSubcmdName);
+ TclNsDecrRefCount(ensembleCmd->nsPtr);
+ ckfree(ensembleCmd);
+ objPtr->typePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupEnsembleCmdRep --
+ *
+ * Makes one Tcl_Obj into a copy of another that is a subcommand of an
+ * ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is allocated, and the namespace that the ensemble is built on
+ * top of gains another reference.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupEnsembleCmdRep(
+ Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr)
+{
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
+ int length = strlen(ensembleCmd->fullSubcmdName);
+
+ copyPtr->typePtr = &tclEnsembleCmdType;
+ copyPtr->internalRep.otherValuePtr = ensembleCopy;
+ ensembleCopy->nsPtr = ensembleCmd->nsPtr;
+ ensembleCopy->epoch = ensembleCmd->epoch;
+ ensembleCopy->token = ensembleCmd->token;
+ ensembleCopy->nsPtr->refCount++;
+ ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
+ Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
+ ensembleCopy->fullSubcmdName = ckalloc(length + 1);
+ memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
+ (unsigned) length+1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringOfEnsembleCmdRep --
+ *
+ * Creates a string representation of a Tcl_Obj that holds a subcommand
+ * of an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object gains a string (UTF-8) representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StringOfEnsembleCmdRep(
+ Tcl_Obj *objPtr)
+{
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ int length = strlen(ensembleCmd->fullSubcmdName);
+
+ objPtr->length = length;
+ objPtr->bytes = ckalloc(length + 1);
+ memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileEnsemble --
+ *
+ * Procedure called to compile an ensemble command. Note that most
+ * ensembles are not compiled, since modifying a compiled ensemble causes
+ * a invalidation of all existing bytecode (expensive!) which is not
+ * normally warranted.
+ *
+ * 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 subcommands of the
+ * ensemble at runtime if a compile-time mapping is possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileEnsemble(
+ 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;
+ Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
+ Tcl_Command ensemble = (Tcl_Command) cmdPtr;
+ Tcl_Parse synthetic;
+ int len, result, flags = 0, i;
+ unsigned numBytes;
+ const char *word;
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Too hard.
+ */
+
+ return TCL_ERROR;
+ }
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+
+ /*
+ * There's a sporting chance we'll be able to compile this. But now we
+ * must check properly. To do that, check that we're compiling an ensemble
+ * that has a compilable command as its appropriate subcommand.
+ */
+
+ if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
+ || mapObj == NULL) {
+ /*
+ * Either not an ensemble or a mapping isn't installed. Crud. Too hard
+ * to proceed.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Also refuse to compile anything that uses a formal parameter list for
+ * now, on the grounds that it is too complex.
+ */
+
+ if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
+ || listObj != NULL) {
+ /*
+ * Figuring out how to compile this has become too much. Bail out.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Next, get the flags. We need them on several code paths so that we can
+ * know whether we're to do prefix matching.
+ */
+
+ (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
+
+ /*
+ * Check to see if there's also a subcommand list; must check to see if
+ * the subcommand we are calling is in that list if it exists, since that
+ * list filters the entries in the map.
+ */
+
+ (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
+ if (listObj != NULL) {
+ int sclen;
+ const char *str;
+ Tcl_Obj *matchObj = NULL;
+
+ if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i=0 ; i<len ; i++) {
+ str = Tcl_GetStringFromObj(elems[i], &sclen);
+ if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
+ /*
+ * Exact match! Excellent!
+ */
+
+ result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ return TCL_ERROR;
+ }
+ goto doneMapLookup;
+ }
+
+ /*
+ * Check to see if we've got a prefix match. A single prefix match
+ * is fine, and allows us to refine our dictionary lookup, but
+ * multiple prefix matches is a Bad Thing and will prevent us from
+ * making progress. Note that we cannot do the lookup immediately
+ * in the prefix case; might be another entry later in the list
+ * that causes things to fail.
+ */
+
+ if ((flags & TCL_ENSEMBLE_PREFIX)
+ && strncmp(word, str, numBytes) == 0) {
+ if (matchObj != NULL) {
+ return TCL_ERROR;
+ }
+ matchObj = elems[i];
+ }
+ }
+ if (matchObj == NULL) {
+ return TCL_ERROR;
+ }
+ result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_DictSearch s;
+ int done, matched;
+ Tcl_Obj *tmpObj;
+
+ /*
+ * No map, so check the dictionary directly.
+ */
+
+ TclNewStringObj(subcmdObj, word, (int) numBytes);
+ result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
+ TclDecrRefCount(subcmdObj);
+ if (result == TCL_OK && targetCmdObj != NULL) {
+ /*
+ * Got it. Skip the fiddling around with prefixes.
+ */
+
+ goto doneMapLookup;
+ }
+
+ /*
+ * We've not literally got a valid subcommand. But maybe we have a
+ * prefix. Check if prefix matches are allowed.
+ */
+
+ if (!(flags & TCL_ENSEMBLE_PREFIX)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Iterate over the keys in the dictionary, checking to see if we're a
+ * prefix.
+ */
+
+ Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
+ matched = 0;
+ while (!done) {
+ if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
+ if (matched++) {
+ /*
+ * Must have matched twice! Not unique, so no point
+ * looking further.
+ */
+
+ break;
+ }
+ targetCmdObj = tmpObj;
+ }
+ Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
+ }
+ Tcl_DictObjDone(&s);
+
+ /*
+ * If we have anything other than a single match, we've failed the
+ * unique prefix check.
+ */
+
+ if (matched != 1) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * OK, we definitely map to something. But what?
+ *
+ * The command we map to is the first word out of the map element. Note
+ * that we also reject dealing with multi-element rewrites if we are in a
+ * safe interpreter, as there is otherwise a (highly gnarly!) way to make
+ * Tcl crash open to exploit.
+ */
+
+ doneMapLookup:
+ if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (len > 1 && Tcl_IsSafe(interp)) {
+ return TCL_ERROR;
+ }
+ targetCmdObj = elems[0];
+
+ Tcl_IncrRefCount(targetCmdObj);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
+ TclDecrRefCount(targetCmdObj);
+ if (cmdPtr == NULL || cmdPtr->compileProc == NULL) {
+ /*
+ * Maps to an undefined command or a command without a compiler.
+ * Cannot compile.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now we've done the mapping process, can now actually try to compile.
+ * We do this by handing off to the subcommand's actual compiler. But to
+ * do that, we have to perform some trickery to rewrite the arguments.
+ */
+
+ TclParseInit(interp, NULL, 0, &synthetic);
+ synthetic.numWords = parsePtr->numWords - 2 + len;
+ TclGrowParseTokenArray(&synthetic, 2*len);
+ synthetic.numTokens = 2*len;
+
+ /*
+ * Now we have the space to work in, install something rewritten. Note
+ * that we are here praying for all our might that none of these words are
+ * a script; the error detection code will crash if that happens and there
+ * is nothing we can do to avoid it!
+ */
+
+ for (i=0 ; i<len ; i++) {
+ int sclen;
+ const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
+
+ synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
+ synthetic.tokenPtr[2*i].start = str;
+ synthetic.tokenPtr[2*i].size = sclen;
+ synthetic.tokenPtr[2*i].numComponents = 1;
+
+ synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
+ synthetic.tokenPtr[2*i+1].start = str;
+ synthetic.tokenPtr[2*i+1].size = sclen;
+ synthetic.tokenPtr[2*i+1].numComponents = 0;
+ }
+
+ /*
+ * Copy over the real argument tokens.
+ */
+
+ for (i=len; i<synthetic.numWords; i++) {
+ int toCopy;
+
+ tokenPtr = TokenAfter(tokenPtr);
+ toCopy = tokenPtr->numComponents + 1;
+ TclGrowParseTokenArray(&synthetic, toCopy);
+ memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
+ sizeof(Tcl_Token) * toCopy);
+ synthetic.numTokens += toCopy;
+ }
+
+ /*
+ * Hand off compilation to the subcommand compiler. At last!
+ */
+
+ result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
+
+ /*
+ * Clean up if necessary.
+ */
+
+ Tcl_FreeParse(&synthetic);
+ return result;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index a516cce..980a785 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -161,7 +161,8 @@ TclSetEnv(
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
- int index, length, nameLength;
+ unsigned nameLength, valueLength;
+ int index, length;
char *p, *oldValue;
const char *p2;
@@ -183,12 +184,11 @@ TclSetEnv(
*/
if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
- char **newEnviron = (char **)
- ckalloc(((unsigned) length + 5) * sizeof(char *));
+ char **newEnviron = ckalloc((length + 5) * sizeof(char *));
memcpy(newEnviron, environ, length * sizeof(char *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
- ckfree((char *) env.ourEnviron);
+ ckfree(env.ourEnviron);
}
environ = env.ourEnviron = newEnviron;
env.ourEnvironSize = length + 5;
@@ -218,7 +218,7 @@ TclSetEnv(
Tcl_DStringFree(&envString);
oldValue = environ[index];
- nameLength = length;
+ nameLength = (unsigned) length;
}
/*
@@ -227,18 +227,19 @@ TclSetEnv(
* and set the environ array value.
*/
- p = ckalloc((unsigned) nameLength + strlen(value) + 2);
- strcpy(p, name);
+ valueLength = strlen(value);
+ p = ckalloc(nameLength + valueLength + 2);
+ memcpy(p, name, nameLength);
p[nameLength] = '=';
- strcpy(p+nameLength+1, value);
+ memcpy(p+nameLength+1, value, valueLength+1);
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
- p = ckrealloc(p, strlen(p2) + 1);
- strcpy(p, p2);
+ p = ckrealloc(p, Tcl_DStringLength(&envString) + 1);
+ memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
@@ -398,19 +399,20 @@ TclUnsetEnv(
*/
#if defined(__WIN32__) || defined(__CYGWIN__)
- string = ckalloc((unsigned) length+2);
+ string = ckalloc(length + 2);
memcpy(string, name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
#else
- string = ckalloc((unsigned) length+1);
+ string = ckalloc(length + 1);
memcpy(string, name, (size_t) length);
string[length] = '\0';
#endif /* WIN32 */
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
- string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1);
- strcpy(string, Tcl_DStringValue(&envString));
+ string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
+ memcpy(string, Tcl_DStringValue(&envString),
+ (unsigned) Tcl_DStringLength(&envString)+1);
Tcl_DStringFree(&envString);
putenv(string);
@@ -566,7 +568,7 @@ EnvTraceProc(
const char *value = TclGetEnv(name2, &valueString);
if (value == NULL) {
- return "no such variable";
+ return (char *) "no such variable";
}
Tcl_SetVar2(interp, name1, name2, value, 0);
Tcl_DStringFree(&valueString);
@@ -643,11 +645,11 @@ ReplaceString(
const int growth = 5;
- env.cache = (char **) ckrealloc((char *) env.cache,
+ env.cache = ckrealloc(env.cache,
(env.cacheSize + growth) * sizeof(char *));
env.cache[env.cacheSize] = newStr;
- (void) memset(env.cache+env.cacheSize+1, (int) 0,
- (size_t) (growth-1) * sizeof(char*));
+ (void) memset(env.cache+env.cacheSize+1, 0,
+ (size_t) (growth-1) * sizeof(char *));
env.cacheSize += growth;
}
}
@@ -682,7 +684,7 @@ TclFinalizeEnvironment(void)
*/
if (env.cache) {
- ckfree((char *) env.cache);
+ ckfree(env.cache);
env.cache = NULL;
env.cacheSize = 0;
#ifndef USE_PUTENV
@@ -720,8 +722,7 @@ TclCygwinPutenv(
/* Can't happen. */
return;
}
- *value = '\0';
- ++value;
+ *(value++) = '\0';
if (*value == '\0') {
value = NULL;
}
@@ -754,13 +755,13 @@ TclCygwinPutenv(
if (strcmp(name, "Path") == 0) {
#ifdef __WIN32__
- SetEnvironmentVariable("PATH", NULL);
+ SetEnvironmentVariableA("PATH", NULL);
#endif
unsetenv("PATH");
}
#ifdef __WIN32__
- SetEnvironmentVariable(name, value);
+ SetEnvironmentVariableA(name, value);
#endif
} else {
char *buf;
@@ -770,7 +771,7 @@ TclCygwinPutenv(
*/
#ifdef __WIN32__
- SetEnvironmentVariable("Path", NULL);
+ SetEnvironmentVariableA("Path", NULL);
#endif
unsetenv("Path");
@@ -785,7 +786,7 @@ TclCygwinPutenv(
}
#ifdef __WIN32__
- SetEnvironmentVariable(name, buf);
+ SetEnvironmentVariableA(name, buf);
#endif
}
}
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 7daa7bb..6816487 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -49,8 +49,8 @@ typedef struct ErrAssocData {
} ErrAssocData;
/*
- * For each exit handler created with a call to Tcl_Create(Late)ExitHandler there is
- * a structure of the following type:
+ * For each exit handler created with a call to Tcl_Create(Late)ExitHandler
+ * there is a structure of the following type:
*/
typedef struct ExitHandler {
@@ -74,19 +74,19 @@ static ExitHandler *firstLateExitPtr = NULL;
TCL_DECLARE_MUTEX(exitMutex)
/*
- * This variable is set to 1 when Tcl_Finalize is called, and at the end of
- * its work, it is reset to 0. The variable is checked by TclInExit() to allow
- * different behavior for exit-time processing, e.g. in closing of files and
- * pipes.
+ * This variable is set to 1 when Tcl_Exit is called. The variable is checked
+ * by TclInExit() to allow different behavior for exit-time processing, e.g.,
+ * in closing of files and pipes.
*/
-static int inFinalize = 0;
+static int inExit = 0;
+
static int subsystemsInitialized = 0;
/*
- * This variable contains the application wide exit handler. It will be
- * called by Tcl_Exit instead of the C-runtime exit if this variable is set
- * to a non-NULL value.
+ * This variable contains the application wide exit handler. It will be called
+ * by Tcl_Exit instead of the C-runtime exit if this variable is set to a
+ * non-NULL value.
*/
static Tcl_ExitProc *appExitPtr = NULL;
@@ -115,8 +115,10 @@ static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
static void BgErrorDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void HandleBgErrors(ClientData clientData);
-static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp,
- CONST char *name1, CONST char *name2, int flags);
+static char * VwaitVarProc(ClientData clientData,
+ Tcl_Interp *interp, const char *name1,
+ const char *name2, int flags);
+static void InvokeExitHandlers(void);
/*
*----------------------------------------------------------------------
@@ -141,10 +143,11 @@ Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
- TclBackgroundException(interp, TCL_ERROR);
+ Tcl_BackgroundException(interp, TCL_ERROR);
}
+
void
-TclBackgroundException(
+Tcl_BackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
@@ -156,7 +159,7 @@ TclBackgroundException(
return;
}
- errPtr = (BgError *) ckalloc(sizeof(BgError));
+ errPtr = ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
@@ -164,10 +167,10 @@ TclBackgroundException(
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
- assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
- Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
@@ -196,7 +199,7 @@ static void
HandleBgErrors(
ClientData clientData) /* Pointer to ErrAssocData structure. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
@@ -207,15 +210,15 @@ HandleBgErrors(
* that could lead us here.
*/
- Tcl_Preserve((ClientData) assocPtr);
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(assocPtr);
+ Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
int code, prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
- * Note we copy the handler command prefix each pass through, so
- * we do support one handler setting another handler.
+ * Note we copy the handler command prefix each pass through, so we do
+ * support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
@@ -223,7 +226,7 @@ HandleBgErrors(
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
- tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
+ tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
@@ -238,8 +241,8 @@ HandleBgErrors(
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
- ckfree((char *) errPtr);
- ckfree((char *) tempObjv);
+ ckfree(errPtr);
+ ckfree(tempObjv);
if (code == TCL_BREAK) {
/*
@@ -252,12 +255,12 @@ HandleBgErrors(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
+ if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
@@ -280,8 +283,8 @@ HandleBgErrors(
}
}
assocPtr->lastBgPtr = NULL;
- Tcl_Release((ClientData) interp);
- Tcl_Release((ClientData) assocPtr);
+ Tcl_Release(interp);
+ Tcl_Release(assocPtr);
}
/*
@@ -307,7 +310,7 @@ TclDefaultBgErrorHandlerObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
@@ -330,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
@@ -342,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
@@ -349,19 +354,26 @@ TclDefaultBgErrorHandlerObjCmd(
}
if (level != 0) {
- /* We're handling a TCL_RETURN exception */
+ /*
+ * We're handling a TCL_RETURN exception.
+ */
+
code = TCL_RETURN;
}
if (code == TCL_OK) {
/*
- * Somehow we got to exception handling with no exception.
- * (Pass TCL_OK to TclBackgroundException()?)
- * Just return without doing anything.
+ * Somehow we got to exception handling with no exception. (Pass
+ * TCL_OK to Tcl_BackgroundException()?) Just return without doing
+ * anything.
*/
+
return TCL_OK;
}
- /* Construct the bgerror command */
+ /*
+ * Construct the bgerror command.
+ */
+
TclNewLiteralStringObj(tempObjv[0], "bgerror");
Tcl_IncrRefCount(tempObjv[0]);
@@ -418,8 +430,11 @@ TclDefaultBgErrorHandlerObjCmd(
*/
saved = Tcl_SaveInterpState(interp, code);
-
- /* Invoke the bgerror command. */
+
+ /*
+ * Invoke the bgerror command.
+ */
+
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
if (code == TCL_ERROR) {
@@ -438,7 +453,8 @@ TclDefaultBgErrorHandlerObjCmd(
TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
} else {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
+
+ if (errChannel != NULL) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
@@ -498,8 +514,7 @@ TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
@@ -509,13 +524,12 @@ TclSetBgErrorHandler(
* First access: initialize.
*/
- assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr = ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
- Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
- (ClientData) assocPtr);
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
Tcl_DecrRefCount(assocPtr->cmdPrefix);
@@ -545,16 +559,14 @@ Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
- assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
@@ -573,7 +585,7 @@ TclGetBgErrorHandler(
*
* Side effects:
* Background error information is freed: if there were any pending error
- * reports, they are cancelled.
+ * reports, they are canceled.
*
*----------------------------------------------------------------------
*/
@@ -583,7 +595,7 @@ BgErrorDeleteProc(
ClientData clientData, /* Pointer to ErrAssocData structure. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
@@ -591,11 +603,11 @@ BgErrorDeleteProc(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
- Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
- Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
@@ -621,9 +633,8 @@ Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- ExitHandler *exitPtr;
+ ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
@@ -637,7 +648,8 @@ Tcl_CreateExitHandler(
*
* TclCreateLateExitHandler --
*
- * Arrange for a given function to be invoked after all pre-thread cleanups
+ * Arrange for a given function to be invoked after all pre-thread
+ * cleanups.
*
* Results:
* None.
@@ -654,9 +666,8 @@ TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- ExitHandler *exitPtr;
+ ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
@@ -678,7 +689,7 @@ TclCreateLateExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -700,7 +711,7 @@ Tcl_DeleteExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
break;
}
}
@@ -720,8 +731,8 @@ Tcl_DeleteExitHandler(
* None.
*
* Side effects:
- * If there is a late exit handler corresponding to proc and clientData then
- * it is canceled; if no such handler exists then nothing happens.
+ * If there is a late exit handler corresponding to proc and clientData
+ * then it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -743,7 +754,7 @@ TclDeleteLateExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
break;
}
}
@@ -777,7 +788,7 @@ Tcl_CreateThreadExitHandler(
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+ exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
@@ -797,7 +808,7 @@ Tcl_CreateThreadExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -819,7 +830,7 @@ Tcl_DeleteThreadExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
return;
}
}
@@ -861,6 +872,49 @@ Tcl_SetExitProc(
return prevExitProc;
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InvokeExitHandlers --
+ *
+ * Call the registered exit handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The exit handlers are invoked, and the ExitHandler struct is
+ * freed.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+InvokeExitHandlers(void)
+{
+ ExitHandler *exitPtr;
+
+ Tcl_MutexLock(&exitMutex);
+ inExit = 1;
+
+ for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
+ /*
+ * Be careful to remove the handler from the list before invoking its
+ * callback. This protects us against double-freeing if the callback
+ * should call Tcl_DeleteExitHandler on itself.
+ */
+
+ firstExitPtr = exitPtr->nextPtr;
+ Tcl_MutexUnlock(&exitMutex);
+ exitPtr->proc(exitPtr->clientData);
+ ckfree(exitPtr);
+ Tcl_MutexLock(&exitMutex);
+ }
+ firstExitPtr = NULL;
+ Tcl_MutexUnlock(&exitMutex);
+}
+
/*
*----------------------------------------------------------------------
@@ -896,14 +950,30 @@ Tcl_Exit(
* returns, so critical is this dependcy.
*/
- currentAppExitPtr((ClientData) INT2PTR(status));
+ currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
/*
* Use default handling.
*/
- Tcl_Finalize();
+ InvokeExitHandlers();
+
+ /*
+ * Ensure the thread-specific data is initialised as it is used in
+ * Tcl_FinalizeThread()
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Now finalize the calling thread only (others are not safely
+ * reachable). Among other things, this triggers a flush of the
+ * Tcl_Channels that may have data enqueued.
+ */
+
+ Tcl_FinalizeThread();
+
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
@@ -937,8 +1007,8 @@ Tcl_Exit(
void
TclInitSubsystems(void)
{
- if (inFinalize != 0) {
- Tcl_Panic("TclInitSubsystems called while finalizing");
+ if (inExit != 0) {
+ Tcl_Panic("TclInitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -974,12 +1044,12 @@ TclInitSubsystems(void)
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
- TclInitObjSubsystem(); /* Register obj types, create
+ TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
- TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
}
TclpInitUnlock();
}
@@ -992,8 +1062,8 @@ TclInitSubsystems(void)
* Tcl_Finalize --
*
* Shut down Tcl. First calls registered exit handlers, then carefully
- * shuts down various subsystems. Called by Tcl_Exit or when the Tcl
- * shared library is being unloaded.
+ * shuts down various subsystems. Should be invoked by user before the
+ * Tcl shared library is being unloaded in an embedded context.
*
* Results:
* None.
@@ -1013,23 +1083,7 @@ Tcl_Finalize(void)
* Invoke exit handlers first.
*/
- Tcl_MutexLock(&exitMutex);
- inFinalize = 1;
- for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
- /*
- * Be careful to remove the handler from the list before invoking its
- * callback. This protects us against double-freeing if the callback
- * should call Tcl_DeleteExitHandler on itself.
- */
-
- firstExitPtr = exitPtr->nextPtr;
- Tcl_MutexUnlock(&exitMutex);
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
- Tcl_MutexLock(&exitMutex);
- }
- firstExitPtr = NULL;
- Tcl_MutexUnlock(&exitMutex);
+ InvokeExitHandlers();
TclpInitLock();
if (subsystemsInitialized == 0) {
@@ -1058,7 +1112,8 @@ Tcl_Finalize(void)
*/
Tcl_MutexLock(&exitMutex);
- for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) {
+ for (exitPtr = firstLateExitPtr; exitPtr != NULL;
+ exitPtr = firstLateExitPtr) {
/*
* Be careful to remove the handler from the list before invoking its
* callback. This protects us against double-freeing if the callback
@@ -1068,7 +1123,7 @@ Tcl_Finalize(void)
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
@@ -1079,6 +1134,7 @@ Tcl_Finalize(void)
* after the exit handlers, because there are order dependencies.
*/
+ TclFinalizeEvaluation();
TclFinalizeExecution();
TclFinalizeEnvironment();
@@ -1134,10 +1190,10 @@ Tcl_Finalize(void)
/*
* There have been several bugs in the past that cause exit handlers to be
* established during Tcl_Finalize processing. Such exit handlers leave
- * malloc'ed memory, and Tcl_FinalizeThreadAlloc or
- * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result
- * can be a mysterious crash on process exit. Check here that nobody's
- * done this.
+ * malloc'ed memory, and Tcl_FinalizeMemorySubsystem or
+ * Tcl_FinalizeThreadAlloc will result in a corrupted heap. The result can
+ * be a mysterious crash on process exit. Check here that nobody's done
+ * this.
*/
if (firstExitPtr != NULL) {
@@ -1184,7 +1240,6 @@ Tcl_Finalize(void)
*/
TclFinalizeMemorySubsystem();
- inFinalize = 0;
alreadyFinalized:
TclFinalizeLock();
@@ -1219,7 +1274,7 @@ Tcl_FinalizeThread(void)
* initialized already.
*/
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
@@ -1232,8 +1287,8 @@ Tcl_FinalizeThread(void)
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ exitPtr->proc(exitPtr->clientData);
+ ckfree(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
@@ -1273,7 +1328,7 @@ Tcl_FinalizeThread(void)
int
TclInExit(void)
{
- return inFinalize;
+ return inExit;
}
/*
@@ -1295,13 +1350,12 @@ TclInExit(void)
int
TclInThreadExit(void)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
if (tsdPtr == NULL) {
return 0;
- } else {
- return tsdPtr->inExit;
}
+ return tsdPtr->inExit;
}
/*
@@ -1327,10 +1381,10 @@ Tcl_VwaitObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
- char *nameString;
+ const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
@@ -1339,36 +1393,48 @@ Tcl_VwaitObjCmd(
nameString = Tcl_GetString(objv[1]);
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done) != TCL_OK) {
+ VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ break;
+ }
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "limit exceeded", NULL);
break;
}
}
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done);
+ VwaitVarProc, &done);
- /*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
- */
-
- Tcl_ResetResult(interp);
if (!foundEvent) {
+ Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
if (!done) {
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ /*
+ * The interpreter's result was already set to the right error message
+ * prior to exiting the loop above.
+ */
+
return TCL_ERROR;
}
+
+ /*
+ * Clear out the interpreter's result, since it may have been set by event
+ * handlers.
+ */
+
+ Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -1377,11 +1443,11 @@ static char *
VwaitVarProc(
ClientData clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
- CONST char *name1, /* Name of variable. */
- CONST char *name2, /* Second part of variable name. */
+ const char *name1, /* Name of variable. */
+ const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
- int *donePtr = (int *) clientData;
+ int *donePtr = clientData;
*donePtr = 1;
return NULL;
@@ -1410,12 +1476,12 @@ Tcl_UpdateObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
- static CONST char *updateOptions[] = {"idletasks", NULL};
- enum updateOptions {REGEXP_IDLETASKS};
+ static const char *const updateOptions[] = {"idletasks", NULL};
+ enum updateOptions {OPT_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
@@ -1425,7 +1491,7 @@ Tcl_UpdateObjCmd(
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
- case REGEXP_IDLETASKS:
+ case OPT_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
@@ -1437,6 +1503,9 @@ Tcl_UpdateObjCmd(
}
while (Tcl_DoOneEvent(flags) != 0) {
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "limit exceeded", NULL);
@@ -1455,11 +1524,11 @@ Tcl_UpdateObjCmd(
#ifdef TCL_THREADS
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* NewThreadProc --
*
- * Bootstrap function of a new Tcl thread.
+ * Bootstrap function of a new Tcl thread.
*
* Results:
* None.
@@ -1467,23 +1536,22 @@ Tcl_UpdateObjCmd(
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
ClientData clientData)
{
- ThreadClientData *cdPtr;
+ ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
- cdPtr = (ThreadClientData *) clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
- ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */
+ ckfree(clientData); /* Allocated in Tcl_CreateThread() */
- (*threadProc)(threadClientData);
+ threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
@@ -1511,21 +1579,23 @@ NewThreadProc(
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
- Tcl_ThreadCreateProc proc, /* Main() function of the thread */
+ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#ifdef TCL_THREADS
- ThreadClientData *cdPtr;
+ ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
+ int result;
- cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
-
- return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr,
- stackSize, flags);
+ result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
+ if (result != TCL_OK) {
+ ckfree(cdPtr);
+ }
+ return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index dc87d70..4fe65d7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6,9 +6,10 @@
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002-2005 by Miguel Sofer.
+ * Copyright (c) 2002-2010 by Miguel Sofer.
* Copyright (c) 2005-2007 by Donal K. Fellows.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,9 +18,11 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"
-
#include <math.h>
-#include <float.h>
+
+#if NRE_ENABLE_ASSERTS
+#include <assert.h>
+#endif
/*
* Hack to determine whether we may expect IEEE floating point. The hack is
@@ -73,7 +76,7 @@ int tclTraceExec = 0;
* disjoint for backward-compatability reasons.
*/
-static const char *operatorStrings[] = {
+static const char *const operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION",
@@ -86,7 +89,7 @@ static const char *operatorStrings[] = {
*/
#ifdef TCL_COMPILE_DEBUG
-static const char *resultStrings[] = {
+static const char *const resultStrings[] = {
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif
@@ -116,8 +119,8 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
*/
typedef struct {
- char *name; /* Name of function. */
- int numArgs; /* Number of arguments for function. */
+ const char *name; /* Name of function. */
+ int numArgs; /* Number of arguments for function. */
} BuiltinFunc;
/*
@@ -126,7 +129,7 @@ typedef struct {
* operand byte.
*/
-static BuiltinFunc tclBuiltinFuncTable[] = {
+static BuiltinFunc const tclBuiltinFuncTable[] = {
{"acos", 1},
{"asin", 1},
{"atan", 1},
@@ -153,12 +156,58 @@ static BuiltinFunc tclBuiltinFuncTable[] = {
{"round", 1},
{"srand", 1},
{"wide", 1},
- {0},
+ {NULL, 0},
};
#define LAST_BUILTIN_FUNC 25
#endif
+
+/*
+ * NR_TEBC
+ * Helpers for NR - non-recursive calls to TEBC
+ * Minimal data required to fully reconstruct the execution state.
+ */
+typedef struct TEBCdata {
+ ByteCode *codePtr; /* Constant until the BC returns */
+ /* -----------------------------------------*/
+ const unsigned char *pc; /* These fields are used on return TO this */
+ unsigned long *catchTop; /* this level: they record the state when a */
+ int cleanup; /* new codePtr was received for NR */
+ Tcl_Obj *auxObjList; /* execution. */
+ int checkInterp;
+ CmdFrame cmdFrame;
+ void * stack[1]; /* Start of the actual combined catch and obj
+ * stacks; the struct will be expanded as
+ * necessary */
+} TEBCdata;
+
+#define TEBC_YIELD() \
+ esPtr->tosPtr = tosPtr; \
+ TD->pc = pc; \
+ TD->cleanup = cleanup; \
+ TclNRAddCallback(interp, TEBCresume, TD, \
+ INT2PTR(1), NULL, NULL)
+
+#define TEBC_DATA_DIG() \
+ pc = TD->pc; \
+ cleanup = TD->cleanup; \
+ tosPtr = esPtr->tosPtr
+
+
+#define PUSH_TAUX_OBJ(objPtr) \
+ do { \
+ objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \
+ auxObjList = objPtr; \
+ } while (0)
+
+#define POP_TAUX_OBJ() \
+ do { \
+ tmpPtr = auxObjList; \
+ auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \
+ Tcl_DecrRefCount(tmpPtr); \
+ } while (0)
+
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
@@ -172,8 +221,8 @@ VarHashCreateVar(
Tcl_Obj *key,
int *newPtr)
{
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
- (char *) key, newPtr);
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
+ key, newPtr);
if (!hPtr) {
return NULL;
@@ -183,7 +232,7 @@ VarHashCreateVar(
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
-
+
/*
* The new macro for ending an instruction; note that a reasonable C-optimiser
* will resolve all branches at compile time. (result) is always a constant;
@@ -196,56 +245,62 @@ VarHashCreateVar(
* resultHandling: 0 indicates no object should be pushed on the stack;
* 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
+ * and within range.
*/
#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
- if (nCleanup == 0) {\
- if (resultHandling != 0) {\
- if ((resultHandling) > 0) {\
- PUSH_OBJECT(objResultPtr);\
- } else {\
- *(++tosPtr) = objResultPtr;\
- }\
- } \
- pc += (pcAdjustment);\
- goto cleanup0;\
- } else if (resultHandling != 0) {\
- if ((resultHandling) > 0) {\
- Tcl_IncrRefCount(objResultPtr);\
- }\
- pc += (pcAdjustment);\
- switch (nCleanup) {\
- case 1: goto cleanup1_pushObjResultPtr;\
- case 2: goto cleanup2_pushObjResultPtr;\
- default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
- }\
- } else {\
- pc += (pcAdjustment);\
- switch (nCleanup) {\
- case 1: goto cleanup1;\
- case 2: goto cleanup2;\
- default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
- }\
- }
+ do { \
+ TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
+ if (nCleanup == 0) { \
+ if (resultHandling != 0) { \
+ if ((resultHandling) > 0) { \
+ PUSH_OBJECT(objResultPtr); \
+ } else { \
+ *(++tosPtr) = objResultPtr; \
+ } \
+ } \
+ pc += (pcAdjustment); \
+ goto cleanup0; \
+ } else if (resultHandling != 0) { \
+ if ((resultHandling) > 0) { \
+ Tcl_IncrRefCount(objResultPtr); \
+ } \
+ pc += (pcAdjustment); \
+ switch (nCleanup) { \
+ case 1: goto cleanup1_pushObjResultPtr; \
+ case 2: goto cleanup2_pushObjResultPtr; \
+ } \
+ } else { \
+ pc += (pcAdjustment); \
+ switch (nCleanup) { \
+ case 1: goto cleanup1; \
+ case 2: goto cleanup2; \
+ } \
+ } \
+ } while (0)
#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
- pc += (pcAdjustment);\
- cleanup = (nCleanup);\
- if (resultHandling) {\
- if ((resultHandling) > 0) {\
- Tcl_IncrRefCount(objResultPtr);\
- }\
- goto cleanupV_pushObjResultPtr;\
- } else {\
- goto cleanupV;\
- }
+ do { \
+ pc += (pcAdjustment); \
+ cleanup = (nCleanup); \
+ if (resultHandling) { \
+ if ((resultHandling) > 0) { \
+ Tcl_IncrRefCount(objResultPtr); \
+ } \
+ goto cleanupV_pushObjResultPtr; \
+ } else { \
+ goto cleanupV; \
+ } \
+ } while (0)
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
- * pair must surround any call inside TclExecuteByteCode (and a few other
+ * pair must surround any call inside TclNRExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
- * to TclExecuteByteCode.
+ * to TclNRExecuteByteCode.
*/
#define CACHE_STACK_INFO() \
@@ -280,36 +335,39 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
-#define CURR_DEPTH (tosPtr - initTosPtr)
+#define CURR_DEPTH ((unsigned long) (tosPtr - initTosPtr))
/*
* Macros used to trace instruction execution. The macros TRACE,
- * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is
+ * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
* only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
- if (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned)(pc - codePtr->codeStart), \
- GetOpcodeName(pc)); \
- printf a; \
+ while (traceInstructions) { \
+ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
+ (int) CURR_DEPTH, \
+ (unsigned) (pc - codePtr->codeStart), \
+ GetOpcodeName(pc)); \
+ printf a; \
+ break; \
}
# define TRACE_APPEND(a) \
- if (traceInstructions) { \
- printf a; \
+ while (traceInstructions) { \
+ printf a; \
+ break; \
}
# define TRACE_WITH_OBJ(a, objPtr) \
- if (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned)(pc - codePtr->codeStart), \
- GetOpcodeName(pc)); \
- printf a; \
- TclPrintObject(stdout, objPtr, 30); \
- fprintf(stdout, "\n"); \
+ while (traceInstructions) { \
+ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
+ (int) CURR_DEPTH, \
+ (unsigned) (pc - codePtr->codeStart), \
+ GetOpcodeName(pc)); \
+ printf a; \
+ TclPrintObject(stdout, objPtr, 30); \
+ fprintf(stdout, "\n"); \
+ break; \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
@@ -325,23 +383,29 @@ VarHashCreateVar(
*/
#define TCL_DTRACE_INST_NEXT() \
- if (TCL_DTRACE_INST_DONE_ENABLED()) {\
- if (curInstName) {\
- TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
- }\
- curInstName = tclInstructionTable[*pc].name;\
- if (TCL_DTRACE_INST_START_ENABLED()) {\
- TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, tosPtr);\
- }\
- } else if (TCL_DTRACE_INST_START_ENABLED()) {\
- TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, (int) CURR_DEPTH,\
- tosPtr);\
- }
+ do { \
+ if (TCL_DTRACE_INST_DONE_ENABLED()) { \
+ if (curInstName) { \
+ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \
+ tosPtr); \
+ } \
+ curInstName = tclInstructionTable[*pc].name; \
+ if (TCL_DTRACE_INST_START_ENABLED()) { \
+ TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \
+ tosPtr); \
+ } \
+ } else if (TCL_DTRACE_INST_START_ENABLED()) { \
+ TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \
+ (int) CURR_DEPTH, tosPtr); \
+ } \
+ } while (0)
#define TCL_DTRACE_INST_LAST() \
- if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\
- TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
- }
-
+ do { \
+ if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \
+ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
+ } \
+ } while (0)
+
/*
* Macro used in this file to save a function call for common uses of
* TclGetNumberFromObj(). The ANSI C "prototype" is:
@@ -351,8 +415,7 @@ VarHashCreateVar(
*/
#ifdef NO_WIDE_TYPE
-
-#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
+#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
*(ptrPtr) = (ClientData) \
@@ -367,10 +430,8 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-
-#else
-
-#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
+#else /* !NO_WIDE_TYPE */
+#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
*(ptrPtr) = (ClientData) \
@@ -389,8 +450,7 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-
-#endif
+#endif /* NO_WIDE_TYPE */
/*
* Macro used in this file to save a function call for common uses of
@@ -400,7 +460,7 @@ VarHashCreateVar(
* int *boolPtr);
*/
-#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
+#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
((((objPtr)->typePtr == &tclIntType) \
|| ((objPtr)->typePtr == &tclBooleanType)) \
? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
@@ -415,12 +475,12 @@ VarHashCreateVar(
*/
#ifdef NO_WIDE_TYPE
-#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else
+#else /* !NO_WIDE_TYPE */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclWideIntType) \
? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
@@ -428,7 +488,7 @@ VarHashCreateVar(
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif
+#endif /* NO_WIDE_TYPE */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -444,24 +504,25 @@ VarHashCreateVar(
#define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0))
/*
- * Custom object type only used in this file; values of its type should never
- * be seen by user scripts.
+ * Macro for checking whether the type is NaN, used when we're thinking about
+ * throwing an error for supplying a non-number number.
*/
-static Tcl_ObjType dictIteratorType = {
- "dictIterator",
- NULL, NULL, NULL, NULL
-};
-
+#ifndef ACCEPT_NAN
+#define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN)
+#else
+#define IsErroringNaNType(type) 0
+#endif
+
/*
- * Auxiliary tables used to compute powers of small integers
+ * Auxiliary tables used to compute powers of small integers.
*/
#if (LONG_MAX == 0x7fffffff)
/*
* Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
- * signed integer
+ * signed integer.
*/
static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
@@ -476,7 +537,8 @@ static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
static const unsigned short Exp32Index[] = {
0, 11, 18, 23, 26, 29, 31, 32, 33
};
-static const size_t Exp32IndexSize = sizeof(Exp32Index)/sizeof(unsigned short);
+static const size_t Exp32IndexSize =
+ sizeof(Exp32Index) / sizeof(unsigned short);
static const long Exp32Value[] = {
19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
@@ -486,7 +548,6 @@ static const long Exp32Value[] = {
1000000000
};
static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
-
#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
@@ -506,14 +567,15 @@ static const Tcl_WideInt MaxBase64[] = {
static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt);
/*
- *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
+ * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
* results fit in a 64-bit signed integer.
*/
static const unsigned short Exp64Index[] = {
0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76
};
-static const size_t Exp64IndexSize = sizeof(Exp64Index)/sizeof(unsigned short);
+static const size_t Exp64IndexSize =
+ sizeof(Exp64Index) / sizeof(unsigned short);
static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)243*243*243*3*3,
(Tcl_WideInt)243*243*243*3*3*3,
@@ -592,10 +654,17 @@ static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)248832*248832*248832*12*12,
(Tcl_WideInt)371293*371293*371293*13*13
};
-static const size_t Exp64ValueSize = sizeof(Exp64Value)/sizeof(Tcl_WideInt);
+static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
+#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */
-#endif
+/*
+ * Markers for ExecuteExtendedBinaryMathOp.
+ */
+#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1)
+#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2)
+#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3)
+
/*
* Declarations for local procedures to this file:
*/
@@ -606,42 +675,107 @@ static int EvalStatsCmd(ClientData clientData,
Tcl_Obj *const objv[]);
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
-static char * GetOpcodeName(unsigned char *pc);
+static const char * GetOpcodeName(const unsigned char *pc);
static void PrintByteCodeInfo(ByteCode *codePtr);
static const char * StringForResultCode(int result);
static void ValidatePcAndStackTop(ByteCode *codePtr,
- unsigned char *pc, int stackTop,
+ const unsigned char *pc, int stackTop,
int stackLowerBound, int checkStack);
#endif /* TCL_COMPILE_DEBUG */
+static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void DeleteExecStack(ExecStack *esPtr);
static void DupExprCodeInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
+static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp,
+ int opcode, Tcl_Obj **constants,
+ Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
+static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode,
+ Tcl_Obj *valuePtr);
static void FreeExprCodeInternalRep(Tcl_Obj *objPtr);
-static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, int catchOnly,
- ByteCode *codePtr);
-static const char * GetSrcInfoForPc(unsigned char *pc, ByteCode *codePtr,
- int *lengthPtr);
+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);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
- unsigned char *pc, Tcl_Obj *opndPtr);
+ const unsigned char *pc, Tcl_Obj *opndPtr);
static void InitByteCodeExecution(Tcl_Interp *interp);
+static inline int OFFSET(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);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
+static Tcl_NRPostProc CopyCallback;
+static Tcl_NRPostProc ExprObjCallback;
+
+static Tcl_NRPostProc TEBCresume;
/*
* The structure below defines a bytecode Tcl object type to hold the
* compiled bytecode for Tcl expressions.
*/
-static Tcl_ObjType exprCodeType = {
+static const Tcl_ObjType exprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
+
+/*
+ * Custom object type only used in this file; values of its type should never
+ * be seen by user scripts.
+ */
+
+static const Tcl_ObjType dictIteratorType = {
+ "dictIterator",
+ ReleaseDictIterator,
+ NULL, NULL, NULL
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReleaseDictIterator --
+ *
+ * This takes apart a dictionary iterator that is stored in the given Tcl
+ * object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deallocates memory, marks the object as being untyped.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ReleaseDictIterator(
+ Tcl_Obj *objPtr)
+{
+ Tcl_DictSearch *searchPtr;
+ Tcl_Obj *dictPtr;
+
+ /*
+ * First kill the search, and then release the reference to the dictionary
+ * that we were holding.
+ */
+
+ searchPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_DictObjDone(searchPtr);
+ ckfree(searchPtr);
+
+ dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ TclDecrRefCount(dictPtr);
+
+ objPtr->typePtr = NULL;
+}
/*
*----------------------------------------------------------------------
@@ -689,7 +823,7 @@ InitByteCodeExecution(
* This procedure creates a new execution environment for Tcl bytecode
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is
* typically created once for each Tcl interpreter (Interp structure) and
- * recursively passed to TclExecuteByteCode to execute ByteCode sequences
+ * recursively passed to TclNRExecuteByteCode to execute ByteCode sequences
* for nested commands.
*
* Results:
@@ -698,32 +832,36 @@ InitByteCodeExecution(
*
* Side effects:
* The bytecode interpreter is also initialized here, as this procedure
- * will be called before any call to TclExecuteByteCode.
+ * will be called before any call to TclNRExecuteByteCode.
*
*----------------------------------------------------------------------
*/
-#define TCL_STACK_INITIAL_SIZE 2000
-
ExecEnv *
TclCreateExecEnv(
- Tcl_Interp *interp) /* Interpreter for which the execution
+ Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
+ int size) /* The initial stack size, in number of words
+ * [sizeof(Tcl_Obj*)] */
{
- ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
- ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack)
- + (size_t) (TCL_STACK_INITIAL_SIZE-1) * sizeof(Tcl_Obj *));
+ ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
+ ExecStack *esPtr = ckalloc(sizeof(ExecStack)
+ + (size_t) (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
TclNewBooleanObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
+ eePtr->interp = interp;
+ eePtr->callbackPtr = NULL;
+ eePtr->corPtr = NULL;
+ eePtr->rewind = 0;
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
esPtr->markerPtr = NULL;
- esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1];
+ esPtr->endPtr = &esPtr->stackWords[size-1];
esPtr->tosPtr = &esPtr->stackWords[-1];
Tcl_MutexLock(&execMutex);
@@ -736,7 +874,6 @@ TclCreateExecEnv(
return eePtr;
}
-#undef TCL_STACK_INITIAL_SIZE
/*
*----------------------------------------------------------------------
@@ -769,7 +906,7 @@ DeleteExecStack(
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
- ckfree((char *) esPtr);
+ ckfree(esPtr);
}
void
@@ -793,7 +930,13 @@ TclDeleteExecEnv(
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
- ckfree((char *) eePtr);
+ if (eePtr->callbackPtr) {
+ Tcl_Panic("Deleting execEnv with pending NRE callbacks!");
+ }
+ if (eePtr->corPtr) {
+ Tcl_Panic("Deleting execEnv with existing coroutine");
+ }
+ ckfree(eePtr);
}
/*
@@ -824,12 +967,12 @@ TclFinalizeExecution(void)
}
/*
- * Auxiliary code to insure that GrowEvaluationStack always returns correctly
+ * Auxiliary code to insure that GrowEvaluationStack always returns correctly
* aligned memory.
*
* WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN
* represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a
- * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
+ * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
*/
#define WALLOCALIGN \
@@ -851,13 +994,12 @@ OFFSET(
}
/*
- * Given a marker, compute where the following aligned memory starts.
+ * Given a marker, compute where the following aligned memory starts.
*/
-#define MEMSTART(markerPtr) \
+#define MEMSTART(markerPtr) \
((markerPtr) + OFFSET(markerPtr))
-
/*
*----------------------------------------------------------------------
*
@@ -904,13 +1046,13 @@ GrowEvaluationStack(
if (needed + offset < 0) {
/*
- * Put a marker pointing to the previous marker in this stack, and
+ * Put a marker pointing to the previous marker in this stack, and
* store it in esPtr as the current marker. Return a pointer to
* the start of aligned memory.
*/
esPtr->markerPtr = tmpMarkerPtr;
- memStart = tmpMarkerPtr + offset;
+ memStart = tmpMarkerPtr + offset;
esPtr->tosPtr = memStart - 1;
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
@@ -961,10 +1103,10 @@ GrowEvaluationStack(
while (needed > newElems) {
newElems *= 2;
}
- newBytes = sizeof (ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
+ newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
- esPtr = (ExecStack *) ckalloc(newBytes);
+ esPtr = ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
@@ -984,7 +1126,7 @@ GrowEvaluationStack(
esPtr->markerPtr = &esPtr->stackWords[0];
memStart = MEMSTART(esPtr->markerPtr);
esPtr->tosPtr = memStart - 1;
-
+
if (move) {
memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *));
esPtr->tosPtr += moveWords;
@@ -1060,7 +1202,7 @@ TclStackFree(
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
- Tcl_Obj **markerPtr;
+ Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
Tcl_Free((char *) freePtr);
@@ -1076,31 +1218,42 @@ TclStackFree(
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
+ marker = *markerPtr;
- if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) {
- Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?");
+ if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) {
+ Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?",
+ freePtr, MEMSTART(markerPtr));
}
- esPtr->tosPtr = markerPtr-1;
- esPtr->markerPtr = (Tcl_Obj **) *markerPtr;
- if (*markerPtr) {
- return;
+ esPtr->tosPtr = markerPtr - 1;
+ esPtr->markerPtr = (Tcl_Obj **) marker;
+ if (marker) {
+ return;
}
/*
- * Return to previous stack.
+ * Return to previous active stack. Note that repeated expansions or
+ * reallocs could have generated several unused intervening stacks: free
+ * them too.
*/
- esPtr->tosPtr = &esPtr->stackWords[-1];
- if (esPtr->prevPtr) {
- eePtr->execStackPtr = esPtr->prevPtr;
+ while (esPtr->nextPtr) {
+ esPtr = esPtr->nextPtr;
}
- if (esPtr->nextPtr) {
- if (!esPtr->prevPtr) {
- eePtr->execStackPtr = esPtr->nextPtr;
- }
- DeleteExecStack(esPtr);
+ esPtr->tosPtr = &esPtr->stackWords[-1];
+ while (esPtr->prevPtr) {
+ ExecStack *tmpPtr = esPtr->prevPtr;
+ if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) {
+ DeleteExecStack(tmpPtr);
+ } else {
+ break;
+ }
}
+ if (esPtr->prevPtr) {
+ eePtr->execStackPtr = esPtr->prevPtr;
+ } else {
+ eePtr->execStackPtr = esPtr;
+ }
}
void *
@@ -1178,20 +1331,127 @@ Tcl_ExprObj(
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
{
+ NRE_callback *rootPtr = TOP_CB(interp);
+ Tcl_Obj *resultPtr;
+
+ TclNewObj(resultPtr);
+ TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
+ NULL, NULL);
+ Tcl_NRExprObj(interp, objPtr, resultPtr);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
+}
+
+static int
+CopyCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **resultPtrPtr = data[0];
+ Tcl_Obj *resultPtr = data[1];
+
+ if (result == TCL_OK) {
+ *resultPtrPtr = resultPtr;
+ Tcl_IncrRefCount(resultPtr);
+ } else {
+ Tcl_DecrRefCount(resultPtr);
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_NRExprObj --
+ *
+ * Request evaluation of the expression in a Tcl_Obj by the NR stack.
+ *
+ * Results:
+ * Returns TCL_OK.
+ *
+ * Side effects:
+ * Compiles objPtr as a Tcl expression and places callbacks on the
+ * NR stack to execute the bytecode and store the result in resultPtr.
+ * If bytecode execution raises an exception, nothing is written
+ * to resultPtr, and the exceptional return code flows up the NR
+ * stack. If the exception is TCL_ERROR, an error message is left
+ * in the interp result and the interp's return options dictionary
+ * holds additional error information too. Execution of the bytecode
+ * may have other side effects, depending on the expression.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_NRExprObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Obj *resultPtr)
+{
+ ByteCode *codePtr;
+
+ /* TODO: consider saving whole state? */
+ Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
+
+ Tcl_IncrRefCount(saveObjPtr);
+
+ codePtr = CompileExprObj(interp, objPtr);
+
+ /* TODO: Confirm reset not required? */
+ /*Tcl_ResetResult(interp);*/
+ Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr,
+ NULL, NULL);
+ return TclNRExecuteByteCode(interp, codePtr);
+}
+
+static int
+ExprObjCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *saveObjPtr = data[0];
+ Tcl_Obj *resultPtr = data[1];
+
+ if (result == TCL_OK) {
+ TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
+ Tcl_SetObjResult(interp, saveObjPtr);
+ }
+ TclDecrRefCount(saveObjPtr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileExprObj --
+ * Compile a Tcl expression value into ByteCode.
+ *
+ * Results:
+ * A (ByteCode *) is returned pointing to the resulting ByteCode.
+ * The caller must manage its refCount and arrange for a call to
+ * TclCleanupByteCode() when the last reference disappears.
+ *
+ * Side effects:
+ * The Tcl_ObjType of objPtr is changed to the "bytecode" type,
+ * and the ByteCode is kept in the internal rep (along with context
+ * data for checking validity) for faster operations the next time
+ * CompileExprObj is called on the same value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ByteCode *
+CompileExprObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
+{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
register ByteCode *codePtr = NULL;
- /* Tcl Internal type of bytecode. Initialized
+ /* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
- int result;
-
- /*
- * Execute the expression after first saving the interpreter's result.
- */
-
- Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
/*
* Get the expression ByteCode from the object. If it exists, make sure it
@@ -1200,13 +1460,13 @@ Tcl_ExprObj(
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
- || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->typePtr = (Tcl_ObjType *) NULL;
+ || (codePtr->nsEpoch != namespacePtr->resolverEpoch)
+ || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
+ FreeExprCodeInternalRep(objPtr);
}
}
if (objPtr->typePtr != &exprCodeType) {
@@ -1240,7 +1500,11 @@ Tcl_ExprObj(
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.otherValuePtr;
+ if (iPtr->varFramePtr->localCachePtr) {
+ codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+ codePtr->localCachePtr->refCount++;
+ }
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile == 2) {
TclPrintByteCodeObj(interp, objPtr);
@@ -1248,38 +1512,7 @@ Tcl_ExprObj(
}
#endif /* TCL_COMPILE_DEBUG */
}
-
- Tcl_ResetResult(interp);
-
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
-
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
-
- /*
- * If the expression evaluated successfully, store a pointer to its value
- * object in resultPtrPtr then restore the old interpreter result. We
- * increment the object's ref count to reflect the reference that we are
- * returning to the caller. We also decrement the ref count of the
- * interpreter's result object after calling Tcl_SetResult since we next
- * store into that field directly.
- */
-
- if (result == TCL_OK) {
- *resultPtrPtr = iPtr->objResultPtr;
- Tcl_IncrRefCount(iPtr->objResultPtr);
-
- Tcl_SetObjResult(interp, saveObjPtr);
- }
- TclDecrRefCount(saveObjPtr);
- return result;
+ return codePtr;
}
/*
@@ -1288,17 +1521,17 @@ Tcl_ExprObj(
* DupExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
- * bytecode. We do not copy the bytecode intrep. Instead, we
- * return without setting copyPtr->typePtr, so the copy is a plain
- * string copy of the expression value, and if it is to be used
- * as a compiled expression, it will just need a recompile.
- *
- * This makes sense, because with Tcl's copy-on-write practices,
- * the usual (only?) time Tcl_DuplicateObj() will be called is
- * when the copy is about to be modified, which would invalidate
- * any copied bytecode anyway. The only reason it might make sense
- * to copy the bytecode is if we had some modifying routines that
- * operated directly on the intrep, like we do for lists and dicts.
+ * bytecode. We do not copy the bytecode intrep. Instead, we return
+ * without setting copyPtr->typePtr, so the copy is a plain string copy
+ * of the expression value, and if it is to be used as a compiled
+ * expression, it will just need a recompile.
+ *
+ * This makes sense, because with Tcl's copy-on-write practices, the
+ * usual (only?) time Tcl_DuplicateObj() will be called is when the copy
+ * is about to be modified, which would invalidate any copied bytecode
+ * anyway. The only reason it might make sense to copy the bytecode is if
+ * we had some modifying routines that operated directly on the intrep,
+ * like we do for lists and dicts.
*
* Results:
* None.
@@ -1323,14 +1556,15 @@ DupExprCodeInternalRep(
* FreeExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
- * bytecode. Frees the storage allocated to hold the internal rep,
- * unless ref counts indicate bytecode execution is still in progress.
+ * bytecode. Frees the storage allocated to hold the internal rep, unless
+ * ref counts indicate bytecode execution is still in progress.
*
* Results:
* None.
*
* Side effects:
- * May free allocated memory. Leaves objPtr untyped.
+ * May free allocated memory. Leaves objPtr untyped.
+ *
*----------------------------------------------------------------------
*/
@@ -1338,37 +1572,34 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
- objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
- * TclCompEvalObj --
+ * TclCompileObj --
*
- * This procedure evaluates the script contained in a Tcl_Obj by first
- * compiling it and then passing it to TclExecuteByteCode.
+ * This procedure compiles the script contained in a Tcl_Obj
*
* Results:
- * The return value is one of the return codes defined in tcl.h (such as
- * TCL_OK), and interp->objResultPtr refers to a Tcl object that either
- * contains the result of executing the code or an error message.
+ * A pointer to the corresponding ByteCode, never NULL.
*
* Side effects:
- * Almost certainly, depending on the ByteCode's instructions.
+ * The object is shimmered to bytecode type
*
*----------------------------------------------------------------------
*/
-int
-TclCompEvalObj(
+ByteCode *
+TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
@@ -1376,23 +1607,7 @@ TclCompEvalObj(
{
register Interp *iPtr = (Interp *) interp;
register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
- int result;
- Namespace *namespacePtr;
-
- /*
- * Check that the interpreter is ready to execute scripts. Note that we
- * manage the interp's runlevel here: it is a small white lie (maybe), but
- * saves a ++/-- pair at each invocation. Amazingly enough, the impact on
- * performance is noticeable.
- */
-
- iPtr->numLevels++;
- if (TclInterpReady(interp) == TCL_ERROR) {
- result = TCL_ERROR;
- goto done;
- }
-
- namespacePtr = iPtr->varFramePtr->nsPtr;
+ Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
/*
* If the object is not already of tclByteCodeType, compile it (and reset
@@ -1418,7 +1633,7 @@ TclCompEvalObj(
* here.
*/
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1429,11 +1644,17 @@ TclCompEvalObj(
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
- /*
- * This byteCode is invalid: free it and recompile.
- */
+ goto recompileObj;
+ }
+ }
- objPtr->typePtr->freeIntRepProc(objPtr);
+ if (codePtr->procPtr == NULL) {
+ /*
+ * Check that any compiled locals do refer to the current proc
+ * environment! If not, recompile.
+ */
+
+ if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
goto recompileObj;
}
}
@@ -1441,17 +1662,11 @@ TclCompEvalObj(
/*
* #280.
* Literal sharing fix. This part of the fix is not required by 8.4
- * because it eval-directs any literals, so just saving the argument
- * locations per command in bytecode is enough, embedded 'eval'
- * commands, etc. get the correct information.
- *
- * It had be backported for 8.5 because we can force the separate
- * compiling of a literal (in a proc body) by putting it into a control
- * command with dynamic pieces, and then such literal may be shared
- * and require their line-information to be reset, as for 8.6, as
- * described below.
+ * nor 8.5, because they eval-direct any literals, so just saving the
+ * argument locations per command in bytecode is enough, embedded
+ * 'eval' commands, etc. get the correct information.
*
- * In 8.6 all the embedded script are compiled, and the resulting
+ * But in 8.6 all the embedded script are compiled, and the resulting
* bytecode stored in the literal. Now the shared literal has bytecode
* with location data for _one_ particular location this literal is
* found at. If we get executed from a different location the bytecode
@@ -1473,77 +1688,69 @@ TclCompEvalObj(
* information.
*/
- if (invoker) {
+ if (!invoker) {
+ return codePtr;
+ }
+
+ {
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
+ ExtCmdLoc *eclPtr;
+ CmdFrame *ctxPtr;
+ int redo;
+
+ if (!hePtr) {
+ return codePtr;
+ }
- if (hePtr) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
- int redo = 0;
- CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
+ eclPtr = Tcl_GetHashValue(hePtr);
+ redo = 0;
+ ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ *ctxPtr = *invoker;
- *ctxPtr = *invoker;
+ if (invoker->type == TCL_LOCATION_BC) {
+ /*
+ * Note: Type BC => ctx.data.eval.path is not used.
+ * ctx.data.tebc.codePtr used instead
+ */
- if (invoker->type == TCL_LOCATION_BC) {
+ TclGetSrcInfoForPc(ctxPtr);
+ if (ctxPtr->type == TCL_LOCATION_SOURCE) {
/*
- * Note: Type BC => ctx.data.eval.path is not used.
- * ctx.data.tebc.codePtr used instead
+ * The reference made by 'TclGetSrcInfoForPc' is dead.
*/
-
- TclGetSrcInfoForPc(ctxPtr);
- if (ctxPtr->type == TCL_LOCATION_SOURCE) {
- /*
- * The reference made by 'TclGetSrcInfoForPc' is
- * dead.
- */
-
- Tcl_DecrRefCount(ctxPtr->data.eval.path);
- ctxPtr->data.eval.path = NULL;
- }
+
+ Tcl_DecrRefCount(ctxPtr->data.eval.path);
+ ctxPtr->data.eval.path = NULL;
}
-
- if (word < ctxPtr->nline) {
- /*
- * Note: We do not care if the line[word] is -1. This
- * is a difference and requires a recompile (location
- * changed from absolute to relative, literal is used
- * fixed and through variable)
- *
- * Example:
- * test info-32.0 using literal of info-24.8
- * (dict with ... vs set body ...).
- */
-
- redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
+ }
+
+ if (word < ctxPtr->nline) {
+ /*
+ * Note: We do not care if the line[word] is -1. This is a
+ * difference and requires a recompile (location changed from
+ * absolute to relative, literal is used fixed and through
+ * variable)
+ *
+ * Example:
+ * test info-32.0 using literal of info-24.8
+ * (dict with ... vs set body ...).
+ */
+
+ redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
&& (eclPtr->start != ctxPtr->line[word]))
|| ((eclPtr->type == TCL_LOCATION_BC)
- && (ctxPtr->type == TCL_LOCATION_SOURCE));
- }
-
- TclStackFree(interp, ctxPtr);
-
- if (redo) {
- goto recompileObj;
- }
+ && (ctxPtr->type == TCL_LOCATION_SOURCE));
}
- }
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
-
- runCompiledObj:
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
+ TclStackFree(interp, ctxPtr);
+ if (!redo) {
+ return codePtr;
+ }
}
- goto done;
}
- recompileObj:
+ recompileObj:
iPtr->errorLine = 1;
/*
@@ -1557,12 +1764,12 @@ TclCompEvalObj(
iPtr->invokeWord = word;
tclByteCodeType.setFromAnyProc(interp, objPtr);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- goto runCompiledObj;
-
- done:
- iPtr->numLevels--;
- return result;
+ codePtr = objPtr->internalRep.otherValuePtr;
+ if (iPtr->varFramePtr->localCachePtr) {
+ codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+ codePtr->localCachePtr->refCount++;
+ }
+ return codePtr;
}
/*
@@ -1694,7 +1901,7 @@ TclIncrObj(
/*
*----------------------------------------------------------------------
*
- * TclExecuteByteCode --
+ * TclNRExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure. It
* returns when a "done" instruction is executed or an error occurs.
@@ -1709,12 +1916,90 @@ TclIncrObj(
*
*----------------------------------------------------------------------
*/
+#define bcFramePtr (&TD->cmdFrame)
+#define initCatchTop ((unsigned long *) (&TD->stack[-1]))
+#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
+#define esPtr (iPtr->execEnvPtr->execStackPtr)
int
-TclExecuteByteCode(
+TclNRExecuteByteCode(
Tcl_Interp *interp, /* Token for command interpreter. */
ByteCode *codePtr) /* The bytecode sequence to interpret. */
{
+ Interp *iPtr = (Interp *) interp;
+ TEBCdata *TD;
+ int size = sizeof(TEBCdata) -1 +
+ + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
+ *(sizeof(void *));
+ int numWords = (size + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *);
+
+ if (iPtr->execEnvPtr->rewind) {
+ return TCL_ERROR;
+ }
+
+ codePtr->refCount++;
+
+ /*
+ * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
+ *
+ * The execution uses a unified stack: first a TEBCdata, immediately
+ * above it a CmdFrame, then the catch stack, then the execution stack.
+ *
+ * Make sure the catch stack is large enough to hold the maximum number of
+ * catch commands that could ever be executing at the same time (this will
+ * be no more than the exception range array's depth). Make sure the
+ * execution stack is large enough to execute this ByteCode.
+ */
+
+ TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
+ esPtr->tosPtr = initTosPtr;
+
+ TD->codePtr = codePtr;
+ TD->pc = codePtr->codeStart;
+ TD->catchTop = initCatchTop;
+ TD->cleanup = 0;
+ TD->auxObjList = NULL;
+ TD->checkInterp = 0;
+
+ /*
+ * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
+ * every time that we call out from this TD, popped when we return to it.
+ */
+
+ 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;
+ bcFramePtr->line = NULL;
+ bcFramePtr->litarg = NULL;
+ bcFramePtr->data.tebc.codePtr = codePtr;
+ bcFramePtr->data.tebc.pc = NULL;
+ bcFramePtr->cmd.str.cmd = NULL;
+ bcFramePtr->cmd.str.len = 0;
+
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.numExecutions++;
+#endif
+
+ /*
+ * Push the callback for bytecode execution
+ */
+
+ TclNRAddCallback(interp, TEBCresume, TD,
+ /*resume*/ INT2PTR(0), NULL, NULL);
+
+ return TCL_OK;
+}
+
+static int
+TEBCresume(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
/*
* Compiler cast directive - not a real variable.
* Interp *iPtr = (Interp *) interp;
@@ -1727,111 +2012,151 @@ TclExecuteByteCode(
#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
+#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET)
+
+ /*
+ * Bottom of allocated stack holds the NR data
+ */
/*
* Constants: variables that do not change during the execution, used
- * sporadically.
+ * sporadically: no special need for speed.
*/
- ExecStack *esPtr;
- Tcl_Obj **initTosPtr; /* Stack top at start of execution. */
- ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */
- Var *compiledLocals;
- Namespace *namespacePtr;
- CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */
+ int instructionCount = 0; /* Counter that is used to work out when to
+ * call Tcl_AsyncReady() */
+ const char *curInstName;
+#ifdef TCL_COMPILE_DEBUG
+ int traceInstructions; /* Whether we are doing instruction-level
+ * tracing or not. */
+#endif
+
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
+
+#define LOCAL(i) (&compiledLocals[(i)])
+#define TCONST(i) (constants[(i)])
/*
- * Globals: variables that store state, must remain valid at all times.
+ * These macros are just meant to save some global variables that are not
+ * used too frequently
*/
- ptrdiff_t *catchTop;
- register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
- * stack. */
- register unsigned char *pc = codePtr->codeStart;
- /* The current program counter. */
- int instructionCount = 0; /* Counter that is used to work out when to
- * call Tcl_AsyncReady() */
- Tcl_Obj *expandNestList = NULL;
- int checkInterp = 0; /* Indicates when a check of interp readyness
- * is necessary. Set by CACHE_STACK_INFO() */
+ TEBCdata *TD = data[0];
+#define auxObjList (TD->auxObjList)
+#define catchTop (TD->catchTop)
+#define codePtr (TD->codePtr)
+#define checkInterp (TD->checkInterp)
+ /* Indicates when a check of interp readyness
+ * is necessary. Set by CACHE_STACK_INFO() */
/*
- * Transfer variables - needed only between opcodes, but not while
- * executing an instruction.
+ * Globals: variables that store state, must remain valid at all times.
*/
- register int cleanup;
- Tcl_Obj *objResultPtr;
+ Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
+ * stack. */
+ const unsigned char *pc; /* The current program counter. */
/*
- * Result variable - needed only when going to checkForcatch or other
- * error handlers; also used as local in some opcodes.
+ * Transfer variables - needed only between opcodes, but not while
+ * executing an instruction.
*/
- int result = TCL_OK; /* Return code returned after execution. */
+ int cleanup = 0;
+ Tcl_Obj *objResultPtr;
/*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
- * NOTE: These are now defined locally where needed.
+ * NOTE: These are now mostly defined locally where needed.
*/
+ Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
+ Tcl_Obj **objv;
+ int objc = 0;
+ int opnd, length, pcAdjustment;
+ Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
- int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
- char *curInstName = NULL;
- /*
- * The execution uses a unified stack: first the catch stack, immediately
- * above it a CmdFrame, then the execution stack.
- *
- * Make sure the catch stack is large enough to hold the maximum number of
- * catch commands that could ever be executing at the same time (this will
- * be no more than the exception range array's depth). Make sure the
- * execution stack is large enough to execute this ByteCode.
- */
-
- catchTop = initCatchTop = (ptrdiff_t *) (
- GrowEvaluationStack(iPtr->execEnvPtr,
- (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) +
- codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1);
- bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
- tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1;
- esPtr = iPtr->execEnvPtr->execStackPtr;
-
- /*
- * TIP #280: Initialize the frame. Do not push it yet.
- */
+#ifdef TCL_COMPILE_DEBUG
+ traceInstructions = (tclTraceExec == 3);
+#endif
- bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
- ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
- bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
- bcFramePtr->framePtr = iPtr->framePtr;
- bcFramePtr->nextPtr = iPtr->cmdFramePtr;
- bcFramePtr->nline = 0;
- bcFramePtr->line = NULL;
-
- bcFramePtr->data.tebc.codePtr = codePtr;
- bcFramePtr->data.tebc.pc = NULL;
- bcFramePtr->cmd.str.cmd = NULL;
- bcFramePtr->cmd.str.len = 0;
+ TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
+ if (!data[1] && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.numExecutions++;
+ if (data[1] /* resume from invocation */) {
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ }
+ NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
+ iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ }
+ if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
+ }
+
+ 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.
+ */
+
+ 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
+ * avoid any side effects caused by the resetting of errorInfo and
+ * errorCode [Bug 804681], which are not needed here. We chose
+ * instead to manipulate the interp's object result directly.
+ *
+ * Note that the result object is now in objResultPtr, it keeps
+ * the refCount it had in its role of iPtr->objResultPtr.
+ */
+
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ iPtr->objResultPtr = objPtr;
+ NEXT_INST_V(0, cleanup, -1);
+ }
+
+ /*
+ * Result not TCL_OK: fall through
+ */
+ }
+
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
- namespacePtr = iPtr->varFramePtr->nsPtr;
- compiledLocals = iPtr->varFramePtr->compiledLocals;
+ if (result != TCL_OK) {
+ pc--;
+ goto processExceptionReturn;
+ }
/*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
@@ -1849,58 +2174,54 @@ TclExecuteByteCode(
* cleanup.
*/
- {
- Tcl_Obj *valuePtr;
-
- cleanupV_pushObjResultPtr:
- switch (cleanup) {
- case 0:
- *(++tosPtr) = (objResultPtr);
- goto cleanup0;
- default:
- cleanup -= 2;
- while (cleanup--) {
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- }
- case 2:
- cleanup2_pushObjResultPtr:
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- case 1:
- cleanup1_pushObjResultPtr:
- valuePtr = OBJ_AT_TOS;
- TclDecrRefCount(valuePtr);
- }
- OBJ_AT_TOS = objResultPtr;
+ cleanupV_pushObjResultPtr:
+ switch (cleanup) {
+ case 0:
+ *(++tosPtr) = (objResultPtr);
goto cleanup0;
+ default:
+ cleanup -= 2;
+ while (cleanup--) {
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
+ }
+ case 2:
+ cleanup2_pushObjResultPtr:
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
+ case 1:
+ cleanup1_pushObjResultPtr:
+ objPtr = OBJ_AT_TOS;
+ TclDecrRefCount(objPtr);
+ }
+ OBJ_AT_TOS = objResultPtr;
+ goto cleanup0;
- cleanupV:
- switch (cleanup) {
- default:
- cleanup -= 2;
- while (cleanup--) {
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- }
- case 2:
- cleanup2:
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- case 1:
- cleanup1:
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- case 0:
- /*
- * We really want to do nothing now, but this is needed for some
- * compilers (SunPro CC).
- */
-
- break;
+ cleanupV:
+ switch (cleanup) {
+ default:
+ cleanup -= 2;
+ while (cleanup--) {
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
}
+ case 2:
+ cleanup2:
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
+ case 1:
+ cleanup1:
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
+ case 0:
+ /*
+ * We really want to do nothing now, but this is needed for some
+ * compilers (SunPro CC).
+ */
+
+ break;
}
- cleanup0:
+ cleanup0:
#ifdef TCL_COMPILE_DEBUG
/*
@@ -1908,7 +2229,7 @@ TclExecuteByteCode(
*/
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0,
- /*checkStack*/ expandNestList == NULL);
+ /*checkStack*/ auxObjList == NULL);
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
@@ -1926,36 +2247,32 @@ TclExecuteByteCode(
*/
if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
- /*
- * Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
- */
-
+ DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
- int localResult;
+ result = Tcl_AsyncInvoke(interp, result);
+ if (result == TCL_ERROR) {
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ }
- DECACHE_STACK_INFO();
- localResult = Tcl_AsyncInvoke(interp, result);
- CACHE_STACK_INFO();
- if (localResult == TCL_ERROR) {
- result = localResult;
- goto checkForCatch;
+ if (TclCanceled(iPtr)) {
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ CACHE_STACK_INFO();
+ goto gotError;
}
}
- if (TclLimitReady(iPtr->limit)) {
- int localResult;
- DECACHE_STACK_INFO();
- localResult = Tcl_LimitCheck(interp);
- CACHE_STACK_INFO();
- if (localResult == TCL_ERROR) {
- result = localResult;
- goto checkForCatch;
+ if (TclLimitReady(iPtr->limit)) {
+ if (Tcl_LimitCheck(interp) == TCL_ERROR) {
+ CACHE_STACK_INFO();
+ goto gotError;
}
}
+ CACHE_STACK_INFO();
}
- TCL_DTRACE_INST_NEXT();
+ TCL_DTRACE_INST_NEXT();
/*
* These two instructions account for 26% of all instructions (according
@@ -1988,14 +2305,13 @@ TclExecuteByteCode(
TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
- } else {
- Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
- if (*pc == INST_SYNTAX) {
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
- }
- cleanup = 2;
- goto processExceptionReturn;
}
+ Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
+ if (*pc == INST_SYNTAX) {
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ }
+ cleanup = 2;
+ goto processExceptionReturn;
}
case INST_RETURN_STK:
@@ -2008,11 +2324,10 @@ TclExecuteByteCode(
TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
- } else {
- Tcl_SetObjResult(interp, objResultPtr);
- cleanup = 1;
- goto processExceptionReturn;
}
+ Tcl_SetObjResult(interp, objResultPtr);
+ cleanup = 1;
+ goto processExceptionReturn;
case INST_DONE:
if (tosPtr > initTosPtr) {
@@ -2032,10 +2347,9 @@ TclExecuteByteCode(
}
#endif
goto checkForCatch;
- } else {
- (void) POP_OBJECT();
- goto abnormalReturn;
}
+ (void) POP_OBJECT();
+ goto abnormalReturn;
case INST_PUSH1:
instPush1Peephole:
@@ -2059,12 +2373,10 @@ TclExecuteByteCode(
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
- case INST_POP: {
- Tcl_Obj *valuePtr;
-
+ case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
/*
* Runtime peephole optimisation: an INST_POP is scheduled at the end
@@ -2080,7 +2392,6 @@ TclExecuteByteCode(
}
#endif
NEXT_INST_F(0, 0, 0);
- }
case INST_START_CMD:
#if !TCL_COMPILE_DEBUG
@@ -2095,90 +2406,109 @@ TclExecuteByteCode(
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (!checkInterp) {
- instStartCmdOK:
- NEXT_INST_F(9, 0, 0);
+ goto instStartCmdOK;
} else if (((codePtr->compileEpoch == iPtr->compileEpoch)
- && (codePtr->nsEpoch == namespacePtr->resolverEpoch))
+ && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch))
|| (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
checkInterp = 0;
- goto instStartCmdOK;
+ instStartCmdOK:
+ NEXT_INST_F(9, 0, 0);
} else {
const char *bytes;
- int length, opnd;
- Tcl_Obj *newObjResultPtr;
- bytes = GetSrcInfoForPc(pc, codePtr, &length);
- DECACHE_STACK_INFO();
- result = Tcl_EvalEx(interp, bytes, length, 0);
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- cleanup = 0;
- if (result == TCL_ERROR) {
- /*
- * Tcl_EvalEx already did the task of logging
- * the error to the stack trace for us, so set
- * a flag to prevent the TEBC exception handling
- * machinery from trying to do it again.
- * Tcl Bug 2037338. See test execute-8.4.
- */
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- goto processExceptionReturn;
+ 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);
- objResultPtr = Tcl_GetObjResult(interp);
- TclNewObj(newObjResultPtr);
- Tcl_IncrRefCount(newObjResultPtr);
- iPtr->objResultPtr = newObjResultPtr;
- NEXT_INST_V(opnd, 0, -1);
+ pc += (opnd-1);
+ PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
+ goto instEvalStk;
}
+ case INST_NOP:
+ pc += 1;
+ goto cleanup0;
+
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
- case INST_OVER: {
- int opnd;
-
+ case INST_OVER:
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = OBJ_AT_DEPTH(opnd);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(5, 0, 1);
- }
case INST_REVERSE: {
- int opnd;
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
- Tcl_Obj *temp = *a;
+ tmpPtr = *a;
*a = *b;
- *b = temp;
+ *b = tmpPtr;
a++; b--;
}
NEXT_INST_F(5, 0, 0);
}
case INST_CONCAT1: {
- int opnd, length, appendLen = 0;
+ int appendLen = 0;
char *bytes, *p;
Tcl_Obj **currPtr;
+ int onlyb = 1;
opnd = TclGetUInt1AtPtr(pc+1);
/*
+ * Detect only-bytearray-or-null case.
+ */
+
+ for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
+ if (((*currPtr)->typePtr != &tclByteArrayType)
+ && ((*currPtr)->bytes != tclEmptyStringRep)) {
+ onlyb = 0;
+ break;
+ } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
+ ((*currPtr)->bytes != NULL)) {
+ onlyb = 0;
+ break;
+ }
+ }
+
+ /*
* Compute the length to be appended.
*/
- for (currPtr=&OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr<=&OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- appendLen += length;
+ if (onlyb) {
+ for (currPtr = &OBJ_AT_DEPTH(opnd-2);
+ appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
+ if ((*currPtr)->bytes != tclEmptyStringRep) {
+ Tcl_GetByteArrayFromObj(*currPtr, &length);
+ appendLen += length;
+ }
+ }
+ } else {
+ for (currPtr = &OBJ_AT_DEPTH(opnd-2);
+ appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
+ bytes = TclGetStringFromObj(*currPtr, &length);
+ if (bytes != NULL) {
+ appendLen += length;
+ }
}
}
@@ -2209,50 +2539,85 @@ TclExecuteByteCode(
*/
objResultPtr = OBJ_AT_DEPTH(opnd-1);
- bytes = TclGetStringFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
+ if (!onlyb) {
+ bytes = TclGetStringFromObj(objResultPtr, &length);
+ if (length + appendLen < 0) {
+ /* TODO: convert panic to error ? */
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
+ INT_MAX);
+ }
#if !TCL_COMPILE_DEBUG
- if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
- TclFreeIntRep(objResultPtr);
- objResultPtr->typePtr = NULL;
- objResultPtr->bytes = ckrealloc(bytes, (length + appendLen + 1));
- objResultPtr->length = length + appendLen;
- p = TclGetString(objResultPtr) + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else {
+ if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
+ TclFreeIntRep(objResultPtr);
+ objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
+ objResultPtr->length = length + appendLen;
+ p = TclGetString(objResultPtr) + length;
+ currPtr = &OBJ_AT_DEPTH(opnd - 2);
+ } else
#endif
- p = (char *) ckalloc((unsigned) (length + appendLen + 1));
- TclNewObj(objResultPtr);
- objResultPtr->bytes = p;
- objResultPtr->length = length + appendLen;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
+ {
+ p = ckalloc(length + appendLen + 1);
+ TclNewObj(objResultPtr);
+ objResultPtr->bytes = p;
+ objResultPtr->length = length + appendLen;
+ currPtr = &OBJ_AT_DEPTH(opnd - 1);
+ }
+
+ /*
+ * Append the remaining characters.
+ */
+
+ for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
+ bytes = TclGetStringFromObj(*currPtr, &length);
+ if (bytes != NULL) {
+ memcpy(p, bytes, (size_t) length);
+ p += length;
+ }
+ }
+ *p = '\0';
+ } else {
+ bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
+ if (length + appendLen < 0) {
+ /* TODO: convert panic to error ? */
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
+ INT_MAX);
+ }
#if !TCL_COMPILE_DEBUG
- }
+ if (!Tcl_IsShared(objResultPtr)) {
+ bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
+ length + appendLen);
+ p = bytes + length;
+ currPtr = &OBJ_AT_DEPTH(opnd - 2);
+ } else
#endif
+ {
+ TclNewObj(objResultPtr);
+ bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
+ length + appendLen);
+ p = bytes;
+ currPtr = &OBJ_AT_DEPTH(opnd - 1);
+ }
- /*
- * Append the remaining characters.
- */
+ /*
+ * Append the remaining characters.
+ */
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- memcpy(p, bytes, (size_t) length);
- p += length;
+ for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
+ if ((*currPtr)->bytes != tclEmptyStringRep) {
+ bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
+ memcpy(p, bytes, (size_t) length);
+ p += length;
+ }
}
}
- *p = '\0';
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
- case INST_EXPAND_START: {
+ case INST_EXPAND_START:
/*
- * Push an element to the expandNestList. This records the current
+ * Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
@@ -2264,18 +2629,13 @@ TclExecuteByteCode(
* error, also in INST_EXPAND_STKTOP).
*/
- Tcl_Obj *objPtr;
-
TclNewObj(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH;
- objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
- expandNestList = objPtr;
+ objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
+ PUSH_TAUX_OBJ(objPtr);
NEXT_INST_F(1, 0, 0);
- }
case INST_EXPAND_STKTOP: {
- int objc, length, i;
- Tcl_Obj **objv, *valuePtr;
+ int i;
ptrdiff_t moved;
/*
@@ -2284,12 +2644,11 @@ TclExecuteByteCode(
* will be removed at checkForCatch.
*/
- valuePtr = OBJ_AT_TOS;
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ objPtr = OBJ_AT_TOS;
+ if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
(void) POP_OBJECT();
@@ -2302,19 +2661,20 @@ TclExecuteByteCode(
length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
DECACHE_STACK_INFO();
- moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1)
- - (Tcl_Obj **) initCatchTop;
-
+ moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
+ - (Tcl_Obj **) TD;
if (moved) {
/*
- * Change the global data to point to the new stack.
+ * 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.
*/
- initCatchTop += moved;
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+
catchTop += moved;
- initTosPtr += moved;
tosPtr += moved;
- esPtr = iPtr->execEnvPtr->execStackPtr;
}
/*
@@ -2326,39 +2686,54 @@ TclExecuteByteCode(
PUSH_OBJECT(objv[i]);
}
- Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(objPtr);
NEXT_INST_F(5, 0, 0);
}
- {
+ case INST_EXPR_STK: {
+ ByteCode *newCodePtr;
+
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ DECACHE_STACK_INFO();
+ newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
+ CACHE_STACK_INFO();
+ cleanup = 1;
+ pc++;
+ TEBC_YIELD();
+ return TclNRExecuteByteCode(interp, newCodePtr);
+ }
+
/*
* INVOCATION BLOCK
*/
- int objc, pcAdjustment;
+ instEvalStk:
+ case INST_EVAL_STK:
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
- case INST_INVOKE_EXPANDED:
- {
- Tcl_Obj *objPtr = expandNestList;
-
- expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
- objc = CURR_DEPTH
- - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
- TclDecrRefCount(objPtr);
- }
+ cleanup = 1;
+ pc += 1;
+ TEBC_YIELD();
+ return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0);
+ case INST_INVOKE_EXPANDED:
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+ POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
goto doInvocation;
- } else {
- /*
- * Nothing was expanded, return {}.
- */
-
- TclNewObj(objResultPtr);
- NEXT_INST_F(1, 0, 1);
}
+ /*
+ * Nothing was expanded, return {}.
+ */
+
+ TclNewObj(objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
@@ -2369,102 +2744,53 @@ TclExecuteByteCode(
pcAdjustment = 2;
doInvocation:
- {
- Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1);
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
- int i;
-
- if (traceInstructions) {
- strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("%u => call ", objc));
- } else {
- fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
- }
- for (i = 0; i < objc; i++) {
- TclPrintObject(stdout, objv[i], 15);
- fprintf(stdout, " ");
- }
- fprintf(stdout, "\n");
- fflush(stdout);
- }
-#endif /*TCL_COMPILE_DEBUG*/
-
- /*
- * Reset the instructionCount variable, since we're about to check
- * for async stuff anyway while processing TclEvalObjvInternal.
- */
-
- instructionCount = 1;
-
- /*
- * Finally, let TclEvalObjvInternal handle the command.
- *
- * TIP #280: Record the last piece of info needed by
- * 'TclGetSrcInfoForPc', and push the frame.
- */
+ if (tclTraceExec >= 2) {
+ int i;
- 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);
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call ", objc));
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
}
- DECACHE_STACK_INFO();
- result = TclEvalObjvInternal(interp, objc, objv,
- /* call from TEBC */(char *) -1, -1, 0);
- CACHE_STACK_INFO();
- if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
- codePtr, pc - codePtr->codeStart);
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
}
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
-
- if (result == TCL_OK) {
- Tcl_Obj *objPtr;
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
-#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- NEXT_INST_V((pcAdjustment+1), objc, 0);
- }
-#endif
- /*
- * Push the call's object result and continue execution with
- * the next instruction.
- */
+ /*
+ * Finally, let TclEvalObjv handle the command.
+ *
+ * TIP #280: Record the last piece of info needed by
+ * 'TclGetSrcInfoForPc', and push the frame.
+ */
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
- objc, cmdNameBuf), Tcl_GetObjResult(interp));
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
- objResultPtr = Tcl_GetObjResult(interp);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult
- * to avoid any side effects caused by the resetting of
- * errorInfo and errorCode [Bug 804681], which are not needed
- * here. We chose instead to manipulate the interp's object
- * result directly.
- *
- * Note that the result object is now in objResultPtr, it
- * keeps the refCount it had in its role of
- * iPtr->objResultPtr.
- */
+ DECACHE_STACK_INFO();
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_V(pcAdjustment, objc, -1);
- } else {
- cleanup = objc;
- goto processExceptionReturn;
- }
- }
+ pc += pcAdjustment;
+ TEBC_YIELD();
+ return TclNREvalObjv(interp, objc, objv,
+ TCL_EVAL_NOERR, NULL);
#if TCL_SUPPORT_84_BYTECODE
- case INST_CALL_BUILTIN_FUNC1: {
+ case INST_CALL_BUILTIN_FUNC1:
/*
* Call one of the built-in pre-8.5 Tcl math functions. This
* translates to INST_INVOKE_STK1 with the first argument of
@@ -2472,47 +2798,45 @@ TclExecuteByteCode(
* function into the stack.
*/
- int opnd, numArgs;
- Tcl_Obj *objPtr;
-
opnd = TclGetUInt1AtPtr(pc+1);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
- Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
+ Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd);
}
- objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
+ TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::");
Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);
/*
* Only 0, 1 or 2 args.
*/
- numArgs = tclBuiltinFuncTable[opnd].numArgs;
- if (numArgs == 0) {
- PUSH_OBJECT(objPtr);
- } else if (numArgs == 1) {
- Tcl_Obj *tmpPtr1 = POP_OBJECT();
- PUSH_OBJECT(objPtr);
- PUSH_OBJECT(tmpPtr1);
- Tcl_DecrRefCount(tmpPtr1);
- } else {
+ {
+ int numArgs = tclBuiltinFuncTable[opnd].numArgs;
Tcl_Obj *tmpPtr1, *tmpPtr2;
- tmpPtr2 = POP_OBJECT();
- tmpPtr1 = POP_OBJECT();
- PUSH_OBJECT(objPtr);
- PUSH_OBJECT(tmpPtr1);
- PUSH_OBJECT(tmpPtr2);
- Tcl_DecrRefCount(tmpPtr1);
- Tcl_DecrRefCount(tmpPtr2);
- }
- objc = numArgs + 1;
+ if (numArgs == 0) {
+ PUSH_OBJECT(objPtr);
+ } else if (numArgs == 1) {
+ tmpPtr1 = POP_OBJECT();
+ PUSH_OBJECT(objPtr);
+ PUSH_OBJECT(tmpPtr1);
+ Tcl_DecrRefCount(tmpPtr1);
+ } else {
+ tmpPtr2 = POP_OBJECT();
+ tmpPtr1 = POP_OBJECT();
+ PUSH_OBJECT(objPtr);
+ PUSH_OBJECT(tmpPtr1);
+ PUSH_OBJECT(tmpPtr2);
+ Tcl_DecrRefCount(tmpPtr1);
+ Tcl_DecrRefCount(tmpPtr2);
+ }
+ objc = numArgs + 1;
+ }
pcAdjustment = 2;
goto doInvocation;
- }
- case INST_CALL_FUNC1: {
+ case INST_CALL_FUNC1:
/*
* Call a non-builtin Tcl math function previously registered by a
* call to Tcl_CreateMathFunc pre-8.5. This is essentially
@@ -2520,16 +2844,11 @@ TclExecuteByteCode(
* ::tcl::mathfunc::$objv[0].
*/
- Tcl_Obj *tmpPtr, *objPtr;
-
- /*
- * Number of arguments. The function name is the 0-th argument.
- */
-
- objc = TclGetUInt1AtPtr(pc+1);
+ objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function
+ * name is the 0-th argument. */
objPtr = OBJ_AT_DEPTH(objc-1);
- tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
+ TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::");
Tcl_AppendObjToObj(tmpPtr, objPtr);
Tcl_DecrRefCount(objPtr);
@@ -2542,7 +2861,6 @@ TclExecuteByteCode(
pcAdjustment = 2;
goto doInvocation;
- }
#else
/*
* INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
@@ -2551,98 +2869,24 @@ TclExecuteByteCode(
*/
case INST_CALL_BUILTIN_FUNC1:
- Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
+ Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
case INST_CALL_FUNC1:
- Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
+ Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
- }
-
- case INST_EVAL_STK: {
- /*
- * Note to maintainers: it is important that INST_EVAL_STK pop its
- * argument from the stack before jumping to checkForCatch! DO NOT
- * OPTIMISE!
- */
-
- Tcl_Obj *objPtr = OBJ_AT_TOS;
-
- DECACHE_STACK_INFO();
-
- /*
- * TIP #280: The invoking context is left NULL for a dynamically
- * constructed command. We cannot match its lines to the outer
- * context.
- */
-
- result = TclCompEvalObj(interp, objPtr, NULL, 0);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- /*
- * Normal return; push the eval's object result.
- */
-
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
-
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult to
- * avoid any side effects caused by the resetting of errorInfo and
- * errorCode [Bug 804681], which are not needed here. We chose
- * instead to manipulate the interp's object result directly.
- *
- * Note that the result object is now in objResultPtr, it keeps
- * the refCount it had in its role of iPtr->objResultPtr.
- */
-
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_F(1, 1, -1);
- } else {
- cleanup = 1;
- goto processExceptionReturn;
- }
- }
-
- case INST_EXPR_STK: {
- Tcl_Obj *objPtr, *valuePtr;
-
- objPtr = OBJ_AT_TOS;
- DECACHE_STACK_INFO();
- /*Tcl_ResetResult(interp);*/
- result = Tcl_ExprObj(interp, objPtr, &valuePtr);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- objResultPtr = valuePtr;
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- NEXT_INST_F(1, 1, -1); /* Already has right refct. */
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
- }
- }
/*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
* instructions set the value of some variables and then jump to some
* common execution code.
*/
- {
- int opnd, pcAdjustment;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
instLoadScalar1:
opnd = TclGetUInt1AtPtr(pc+1);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2664,7 +2908,7 @@ TclExecuteByteCode(
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2696,7 +2940,7 @@ TclExecuteByteCode(
doLoadArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
@@ -2716,10 +2960,8 @@ TclExecuteByteCode(
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
if (varPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
}
cleanup = 1;
goto doCallPtrGetVar;
@@ -2743,25 +2985,23 @@ TclExecuteByteCode(
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1,
&arrayPtr);
- if (varPtr) {
- if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
- /*
- * No errors, no traces: just get the value.
- */
-
- objResultPtr = varPtr->value.objPtr;
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(1, cleanup, 1);
- }
- pcAdjustment = 1;
- opnd = -1;
- goto doCallPtrGetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+ if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(1, cleanup, 1);
+ }
+ pcAdjustment = 1;
+ opnd = -1;
+
doCallPtrGetVar:
/*
* There are either errors or the variable is traced: call
@@ -2772,23 +3012,16 @@ TclExecuteByteCode(
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
- if (objResultPtr) {
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(pcAdjustment, cleanup, 1);
- } else {
+ if (!objResultPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_LOAD instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_STORE and related instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -2797,10 +3030,7 @@ TclExecuteByteCode(
*/
{
- int opnd, pcAdjustment, storeFlags;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr, *valuePtr;
+ int storeFlags;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -2814,7 +3044,7 @@ TclExecuteByteCode(
doStoreArrayDirect:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
@@ -2845,39 +3075,40 @@ TclExecuteByteCode(
doStoreScalarDirect:
valuePtr = OBJ_AT_TOS;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- if (TclIsVarDirectWritable(varPtr)) {
- doStoreVarDirect:
- /*
- * No traces, no errors, plain 'set': we can safely inline. The
- * value *will* be set to what's requested, so that the stack top
- * remains pointing to the same Tcl_Obj.
- */
+ if (!TclIsVarDirectWritable(varPtr)) {
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ part1Ptr = NULL;
+ goto doStoreScalar;
+ }
- valuePtr = varPtr->value.objPtr;
- if (valuePtr != NULL) {
- TclDecrRefCount(valuePtr);
- }
- objResultPtr = OBJ_AT_TOS;
- varPtr->value.objPtr = objResultPtr;
+ /*
+ * No traces, no errors, plain 'set': we can safely inline. The value
+ * *will* be set to what's requested, so that the stack top remains
+ * pointing to the same Tcl_Obj.
+ */
+
+ doStoreVarDirect:
+ valuePtr = varPtr->value.objPtr;
+ if (valuePtr != NULL) {
+ TclDecrRefCount(valuePtr);
+ }
+ objResultPtr = OBJ_AT_TOS;
+ varPtr->value.objPtr = objResultPtr;
#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- tosPtr--;
- NEXT_INST_F((pcAdjustment+1), 0, 0);
- }
+ if (*(pc+pcAdjustment) == INST_POP) {
+ tosPtr--;
+ NEXT_INST_F((pcAdjustment+1), 0, 0);
+ }
#else
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
- Tcl_IncrRefCount(objResultPtr);
- NEXT_INST_F(pcAdjustment, 0, 0);
- }
- storeFlags = TCL_LEAVE_ERR_MSG;
- part1Ptr = NULL;
- goto doStoreScalar;
+ Tcl_IncrRefCount(objResultPtr);
+ NEXT_INST_F(pcAdjustment, 0, 0);
case INST_LAPPEND_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
@@ -2930,16 +3161,14 @@ TclExecuteByteCode(
#endif
varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
- if (varPtr) {
- cleanup = ((part2Ptr == NULL)? 2 : 3);
- pcAdjustment = 1;
- opnd = -1;
- goto doCallPtrSetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+ cleanup = ((part2Ptr == NULL)? 2 : 3);
+ pcAdjustment = 1;
+ opnd = -1;
+ goto doCallPtrSetVar;
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -2970,7 +3199,7 @@ TclExecuteByteCode(
doStoreArray:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
@@ -2982,13 +3211,11 @@ TclExecuteByteCode(
doStoreArrayDirectFailed:
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
- if (varPtr) {
- goto doCallPtrSetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+ goto doCallPtrSetVar;
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3018,7 +3245,7 @@ TclExecuteByteCode(
doStoreScalar:
valuePtr = OBJ_AT_TOS;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -3032,28 +3259,22 @@ TclExecuteByteCode(
objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
- if (objResultPtr) {
-#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- NEXT_INST_V((pcAdjustment+1), cleanup, 0);
- }
-#endif
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(pcAdjustment, cleanup, 1);
- } else {
+ if (!objResultPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
+ }
+#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
}
/*
* End of INST_STORE and related instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -3064,14 +3285,11 @@ TclExecuteByteCode(
/*TODO: Consider more untangling here; merge with LOAD and STORE ? */
{
- Tcl_Obj *objPtr, *incrPtr;
- int opnd, pcAdjustment;
+ Tcl_Obj *incrPtr;
#ifndef NO_WIDE_TYPE
Tcl_WideInt w;
#endif
- long i;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
+ long increment;
case INST_INCR_SCALAR1:
case INST_INCR_ARRAY1:
@@ -3095,8 +3313,8 @@ TclExecuteByteCode(
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
- i = TclGetInt1AtPtr(pc+1);
- incrPtr = Tcl_NewIntObj(i);
+ increment = TclGetInt1AtPtr(pc+1);
+ incrPtr = Tcl_NewIntObj(increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 2;
@@ -3106,61 +3324,57 @@ TclExecuteByteCode(
part2Ptr = OBJ_AT_TOS;
objPtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
- O2S(objPtr), O2S(part2Ptr), i));
+ O2S(objPtr), O2S(part2Ptr), increment));
} else {
part2Ptr = NULL;
objPtr = OBJ_AT_TOS;
- TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
+ TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment));
}
part1Ptr = objPtr;
opnd = -1;
varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
- if (varPtr) {
- cleanup = ((part2Ptr == NULL)? 1 : 2);
- goto doIncrVar;
- } else {
+ if (!varPtr) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
- goto checkForCatch;
+ goto gotError;
}
+ cleanup = ((part2Ptr == NULL)? 1 : 2);
+ goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
- i = TclGetInt1AtPtr(pc+2);
- incrPtr = Tcl_NewIntObj(i);
+ increment = TclGetInt1AtPtr(pc+2);
+ incrPtr = Tcl_NewIntObj(increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 3;
doIncrArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
cleanup = 1;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
- TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i));
+ TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment));
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
- if (varPtr) {
- goto doIncrVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
- goto checkForCatch;
+ goto gotError;
}
+ goto doIncrVar;
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
- i = TclGetInt1AtPtr(pc+2);
+ increment = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
cleanup = 0;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -3173,16 +3387,16 @@ TclExecuteByteCode(
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
if (type == TCL_NUMBER_LONG) {
long augend = *((const long *)ptr);
- long sum = augend + i;
+ long sum = augend + increment;
/*
* Overflow when (augend and sum have different sign) and
- * (augend and i have the same sign). This is encapsulated
- * in the Overflowing macro.
+ * (augend and increment have the same sign). This is
+ * encapsulated in the Overflowing macro.
*/
- if (!Overflowing(augend, i, sum)) {
- TRACE(("%u %ld => ", opnd, i));
+ if (!Overflowing(augend, increment, sum)) {
+ TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
TclNewLongObj(objResultPtr, sum);
@@ -3195,42 +3409,40 @@ TclExecuteByteCode(
goto doneIncr;
}
#ifndef NO_WIDE_TYPE
- {
- w = (Tcl_WideInt)augend;
-
- TRACE(("%u %ld => ", opnd, i));
- if (Tcl_IsShared(objPtr)) {
- objPtr->refCount--; /* We know it's shared. */
- objResultPtr = Tcl_NewWideIntObj(w+i);
- Tcl_IncrRefCount(objResultPtr);
- varPtr->value.objPtr = objResultPtr;
- } else {
- objResultPtr = objPtr;
+ w = (Tcl_WideInt)augend;
+
+ TRACE(("%u %ld => ", opnd, increment));
+ if (Tcl_IsShared(objPtr)) {
+ objPtr->refCount--; /* We know it's shared. */
+ objResultPtr = Tcl_NewWideIntObj(w+increment);
+ Tcl_IncrRefCount(objResultPtr);
+ varPtr->value.objPtr = objResultPtr;
+ } else {
+ objResultPtr = objPtr;
- /*
- * We know the sum value is outside the long
- * range; use macro form that doesn't range test
- * again.
- */
+ /*
+ * We know the sum value is outside the long range;
+ * use macro form that doesn't range test again.
+ */
- TclSetWideIntObj(objPtr, w+i);
- }
- goto doneIncr;
+ TclSetWideIntObj(objPtr, w+increment);
}
+ goto doneIncr;
#endif
} /* end if (type == TCL_NUMBER_LONG) */
#ifndef NO_WIDE_TYPE
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
- w = *((const Tcl_WideInt *)ptr);
- sum = w + i;
+
+ w = *((const Tcl_WideInt *) ptr);
+ sum = w + increment;
/*
* Check for overflow.
*/
- if (!Overflowing(w, i, sum)) {
- TRACE(("%u %ld => ", opnd, i));
+ if (!Overflowing(w, increment, sum)) {
+ TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
objResultPtr = Tcl_NewWideIntObj(sum);
@@ -3260,34 +3472,33 @@ TclExecuteByteCode(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, i);
- result = TclIncrObj(interp, objResultPtr, incrPtr);
- Tcl_DecrRefCount(incrPtr);
- if (result == TCL_OK) {
- goto doneIncr;
- } else {
+ TclNewLongObj(incrPtr, increment);
+ if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
+ Tcl_DecrRefCount(incrPtr);
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DecrRefCount(incrPtr);
+ goto doneIncr;
}
/*
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, i);
+ TclNewLongObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %ld => ", opnd, i));
+ TRACE(("%u %ld => ", opnd, increment));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -3300,15 +3511,13 @@ TclExecuteByteCode(
} else {
objResultPtr = objPtr;
}
- result = TclIncrObj(interp, objResultPtr, incrPtr);
- Tcl_DecrRefCount(incrPtr);
- if (result == TCL_OK) {
- goto doneIncr;
- } else {
+ if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
+ Tcl_DecrRefCount(incrPtr);
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DecrRefCount(incrPtr);
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
@@ -3318,8 +3527,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
doneIncr:
@@ -3334,21 +3542,13 @@ TclExecuteByteCode(
/*
* End of INST_INCR instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_EXIST instructions.
*/
- {
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
- case INST_EXIST_SCALAR: {
- int opnd = TclGetUInt4AtPtr(pc+1);
-
- varPtr = &(compiledLocals[opnd]);
+ case INST_EXIST_SCALAR:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -3368,16 +3568,14 @@ TclExecuteByteCode(
* Tricky! Arrays always exist.
*/
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
- }
-
- case INST_EXIST_ARRAY: {
- int opnd = TclGetUInt4AtPtr(pc+1);
+ case INST_EXIST_ARRAY:
+ opnd = TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
@@ -3403,10 +3601,9 @@ TclExecuteByteCode(
}
}
doneExistArray:
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 1, 1);
- }
case INST_EXIST_ARRAY_STK:
cleanup = 2;
@@ -3436,89 +3633,223 @@ TclExecuteByteCode(
varPtr = NULL;
}
}
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
- }
/*
* End of INST_EXIST instructions.
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
+ * Start of INST_UNSET instructions.
*/
- case INST_UPVAR: {
- int opnd;
- Var *varPtr, *otherPtr;
+ {
+ int flags;
- TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+ case INST_UNSET_SCALAR:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd));
+ if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
+ /*
+ * No errors, no traces, no searches: just make the variable cease
+ * to exist.
+ */
- {
- CallFrame *framePtr, *savedFramePtr;
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetScalar;
+ }
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 0, 0);
+ }
- result = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
- if (result != -1) {
+ slowUnsetScalar:
+ DECACHE_STACK_INFO();
+ if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags,
+ opnd) != TCL_OK && flags) {
+ goto errorInUnset;
+ }
+ CACHE_STACK_INFO();
+ NEXT_INST_F(6, 0, 0);
+
+ case INST_UNSET_ARRAY:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ part2Ptr = OBJ_AT_TOS;
+ arrayPtr = LOCAL(opnd);
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%s %u \"%.30s\"\n",
+ (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
+ if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
/*
- * Locate the other variable.
+ * No nasty traces and element exists, so we can proceed to
+ * unset it. Might still not exist though...
*/
- savedFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = framePtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr = savedFramePtr;
- if (otherPtr) {
- result = TCL_OK;
- goto doLinkVars;
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetArray;
}
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 1, 0);
+ } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) {
+ /*
+ * Don't need to do anything here.
+ */
+
+ NEXT_INST_F(6, 1, 0);
}
- result = TCL_ERROR;
- goto checkForCatch;
}
+ slowUnsetArray:
+ DECACHE_STACK_INFO();
+ varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset",
+ 0, 0, arrayPtr, opnd);
+ if (!varPtr) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ goto errorInUnset;
+ }
+ } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr,
+ flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
+ goto errorInUnset;
+ }
+ CACHE_STACK_INFO();
+ NEXT_INST_F(6, 1, 0);
- case INST_VARIABLE:
- TRACE(("variable "));
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- if (otherPtr) {
- /*
- * Do the [variable] magic.
- */
+ case INST_UNSET_ARRAY_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 2;
+ part2Ptr = OBJ_AT_TOS; /* element name */
+ part1Ptr = OBJ_UNDER_TOS; /* array name */
+ TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"),
+ O2S(part1Ptr), O2S(part2Ptr)));
+ goto doUnsetStk;
- TclSetVarNamespaceVar(otherPtr);
- result = TCL_OK;
- goto doLinkVars;
+ case INST_UNSET_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 1;
+ part2Ptr = NULL;
+ part1Ptr = OBJ_AT_TOS; /* variable name */
+ TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr)));
+
+ doUnsetStk:
+ DECACHE_STACK_INFO();
+ if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK
+ && (flags & TCL_LEAVE_ERR_MSG)) {
+ goto errorInUnset;
}
- result = TCL_ERROR;
- goto checkForCatch;
+ CACHE_STACK_INFO();
+ NEXT_INST_V(2, cleanup, 0);
+
+ errorInUnset:
+ CACHE_STACK_INFO();
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+
+ /*
+ * This is really an unset operation these days. Do not issue.
+ */
+
+ case INST_DICT_DONE:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u\n", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ }
+ varPtr->value.objPtr = NULL;
+ } else {
+ DECACHE_STACK_INFO();
+ TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
+ CACHE_STACK_INFO();
+ }
+ NEXT_INST_F(5, 0, 0);
+ }
+
+ /*
+ * End of INST_UNSET instructions.
+ * -----------------------------------------------------------------
+ * Start of variable linking instructions.
+ */
+
+ {
+ Var *otherPtr;
+ CallFrame *framePtr, *savedFramePtr;
+ Tcl_Namespace *nsPtr;
+ Namespace *savedNsPtr;
+
+ case INST_UPVAR:
+ TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+
+ if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) {
+ goto gotError;
+ }
+
+ /*
+ * Locate the other variable.
+ */
+
+ savedFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = framePtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1,
+ /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (!otherPtr) {
+ goto gotError;
+ }
+ goto doLinkVars;
case INST_NSUPVAR:
TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) {
+ goto gotError;
+ }
- {
- Tcl_Namespace *nsPtr, *savedNsPtr;
+ /*
+ * Locate the other variable.
+ */
- result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
- if (result == TCL_OK) {
- /*
- * Locate the other variable.
- */
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ if (!otherPtr) {
+ goto gotError;
+ }
+ goto doLinkVars;
- savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
- if (otherPtr) {
- goto doLinkVars;
- }
- }
- result = TCL_ERROR;
- goto checkForCatch;
+ case INST_VARIABLE:
+ TRACE(("variable "));
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ if (!otherPtr) {
+ goto gotError;
}
+ /*
+ * Do the [variable] magic.
+ */
+
+ TclSetVarNamespaceVar(otherPtr);
+
doLinkVars:
/*
@@ -3528,7 +3859,7 @@ TclExecuteByteCode(
*/
opnd = TclGetInt4AtPtr(pc+1);;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
&& (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
if (!TclIsVarUndefined(varPtr)) {
@@ -3539,7 +3870,7 @@ TclExecuteByteCode(
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
- goto doLinkVarsDone;
+ NEXT_INST_F(5, 1, 0);
}
if (TclIsVarInHash(linkPtr)) {
VarHashRefCount(linkPtr)--;
@@ -3553,11 +3884,9 @@ TclExecuteByteCode(
if (TclIsVarInHash(otherPtr)) {
VarHashRefCount(otherPtr)++;
}
- } else {
- result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd);
- if (result != TCL_OK) {
- goto checkForCatch;
- }
+ } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0,
+ opnd) != TCL_OK) {
+ goto gotError;
}
/*
@@ -3565,35 +3894,34 @@ TclExecuteByteCode(
* variables - and [variable] did not push it at all.
*/
- doLinkVarsDone:
NEXT_INST_F(5, 1, 0);
}
- case INST_JUMP1: {
- int opnd = TclGetInt1AtPtr(pc+1);
+ /*
+ * End of variable linking instructions.
+ * -----------------------------------------------------------------
+ */
+ case INST_JUMP1:
+ opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
- }
-
- case INST_JUMP4: {
- int opnd = TclGetInt4AtPtr(pc+1);
+ case INST_JUMP4:
+ opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
- }
{
int jmpOffset[2], b;
- Tcl_Obj *valuePtr;
/* TODO: consider rewrite so we don't compute the offset we're not
* going to take. */
case INST_JUMP_FALSE4:
jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
- jmpOffset[1] = 5; /* TRUE offset*/
+ jmpOffset[1] = 5; /* TRUE offset */
goto doCondJump;
case INST_JUMP_TRUE4:
@@ -3615,12 +3943,11 @@ TclExecuteByteCode(
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
- result = TclGetBooleanFromObj(interp, valuePtr, &b);
- if (result != TCL_OK) {
+ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
? 0 : 1]), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
@@ -3648,7 +3975,6 @@ TclExecuteByteCode(
case INST_JUMP_TABLE: {
Tcl_HashEntry *hPtr;
JumptableInfo *jtPtr;
- int opnd;
/*
* Jump to location looked up in a hashtable; fall through to next
@@ -3684,27 +4010,25 @@ TclExecuteByteCode(
*/
int i1, i2, iResult;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- result = TclGetBooleanFromObj(NULL, valuePtr, &i1);
- if (result != TCL_OK) {
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
+ if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
- CACHE_STACK_INFO();
- goto checkForCatch;
+ CACHE_STACK_INFO();
+ goto gotError;
}
- result = TclGetBooleanFromObj(NULL, value2Ptr, &i2);
- if (result != TCL_OK) {
+ if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
(value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
- CACHE_STACK_INFO();
- goto checkForCatch;
+ CACHE_STACK_INFO();
+ goto gotError;
}
if (*pc == INST_LOR) {
@@ -3712,61 +4036,44 @@ TclExecuteByteCode(
} else {
iResult = (i1 && i2);
}
- objResultPtr = constants[iResult];
+ objResultPtr = TCONST(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
NEXT_INST_F(1, 2, 1);
}
/*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
- case INST_LIST: {
+ {
+ int index, numIndices, fromIdx, toIdx;
+ int nocase, match, length2, cflags, s1len, s2len;
+ const char *s1, *s2;
+
+ case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj and then
* decrement their ref counts.
*/
- int opnd;
-
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
- }
-
- case INST_LIST_LENGTH: {
- Tcl_Obj *valuePtr;
- int length;
+ case INST_LIST_LENGTH:
valuePtr = OBJ_AT_TOS;
-
- result = TclListObjLength(interp, valuePtr, &length);
- if (result == TCL_OK) {
- TclNewIntObj(objResultPtr, length);
- TRACE(("%.20s => %d\n", O2S(valuePtr), length));
- NEXT_INST_F(1, 1, 1);
- } else {
+ if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
}
- }
-
- case INST_LIST_INDEX: {
- /*** lindex with objc == 3 ***/
-
- /* Variables also for INST_LIST_INDEX_IMM */
-
- int listc, idx, opnd, pcAdjustment;
- Tcl_Obj **listv;
- Tcl_Obj *valuePtr, *value2Ptr;
-
- /*
- * Pop the two operands.
- */
+ TclNewIntObj(objResultPtr, length);
+ TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+ NEXT_INST_F(1, 1, 1);
+ case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
@@ -3774,10 +4081,10 @@ TclExecuteByteCode(
* Extract the desired list element.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
- if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType)
- && (TclGetIntForIndexM(NULL , value2Ptr, listc-1,
- &idx) == TCL_OK)) {
+ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
+ && (value2Ptr->typePtr != &tclListType)
+ && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
+ &index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
@@ -3785,25 +4092,22 @@ TclExecuteByteCode(
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
- if (objResultPtr) {
- /*
- * Stash the list element on the stack.
- */
-
- TRACE(("%.20s %.20s => %s\n",
- O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
- NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
- } else {
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- case INST_LIST_INDEX_IMM:
- /*** lindex with objc==3 and index in bytecode stream ***/
+ /*
+ * Stash the list element on the stack.
+ */
- pcAdjustment = 5;
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
+
+ case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode
+ * stream */
/*
* Pop the list and get the index.
@@ -3817,84 +4121,68 @@ TclExecuteByteCode(
* in the process.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
-
- if (result == TCL_OK) {
- /*
- * Select the list item based on the index. Negative operand means
- * end-based indexing.
- */
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
- if (opnd < -1) {
- idx = opnd+1 + listc;
- } else {
- idx = opnd;
- }
+ /*
+ * Select the list item based on the index. Negative operand means
+ * end-based indexing.
+ */
- lindexFastPath:
- if (idx >= 0 && idx < listc) {
- objResultPtr = listv[idx];
- } else {
- TclNewObj(objResultPtr);
- }
+ if (opnd < -1) {
+ index = opnd+1 + objc;
+ } else {
+ index = opnd;
+ }
+ pcAdjustment = 5;
- TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
- objResultPtr);
- NEXT_INST_F(pcAdjustment, 1, 1);
+ lindexFastPath:
+ if (index >= 0 && index < objc) {
+ objResultPtr = objv[index];
} else {
- TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
+ TclNewObj(objResultPtr);
}
- }
- case INST_LIST_INDEX_MULTI: {
+ TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
+ objResultPtr);
+ NEXT_INST_F(pcAdjustment, 1, 1);
+
+ case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */
/*
- * 'lindex' with multiple index args:
- *
* Determine the count of index args.
*/
- int numIdx, opnd;
-
opnd = TclGetUInt4AtPtr(pc+1);
- numIdx = opnd-1;
+ numIndices = opnd-1;
/*
* Do the 'lindex' operation.
*/
- objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIdx),
- numIdx, &OBJ_AT_DEPTH(numIdx - 1));
+ objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices),
+ numIndices, &OBJ_AT_DEPTH(numIndices - 1));
+ if (!objResultPtr) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
/*
- * Check for errors.
+ * Set result.
*/
- if (objResultPtr) {
- /*
- * Set result.
- */
+ TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd, -1);
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
- NEXT_INST_V(5, opnd, -1);
- } else {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- }
-
- case INST_LSET_FLAT: {
+ case INST_LSET_FLAT:
/*
* Lset with 3, 5, or more args. Get the number of index args.
*/
- int numIdx,opnd;
- Tcl_Obj *valuePtr, *value2Ptr;
-
opnd = TclGetUInt4AtPtr(pc + 1);
- numIdx = opnd - 2;
+ numIndices = opnd - 2;
/*
* Get the old value of variable, and remove the stack ref. This is
@@ -3903,47 +4191,28 @@ TclExecuteByteCode(
* Tcl_DecrRefCount.
*/
- value2Ptr = POP_OBJECT();
- Tcl_DecrRefCount(value2Ptr); /* This one should be done here */
-
- /*
- * Get the new element value.
- */
-
- valuePtr = OBJ_AT_TOS;
+ valuePtr = POP_OBJECT();
+ Tcl_DecrRefCount(valuePtr); /* This one should be done here */
/*
* Compute the new variable value.
*/
- objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
- &OBJ_AT_DEPTH(numIdx), valuePtr);
-
- /*
- * Check for errors.
- */
-
- if (objResultPtr) {
- /*
- * Set result.
- */
-
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
- NEXT_INST_V(5, (numIdx+1), -1);
- } else {
+ objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
+ &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- }
- case INST_LSET_LIST: {
/*
- * 'lset' with 4 args.
+ * Set result.
*/
- Tcl_Obj *objPtr, *valuePtr, *value2Ptr;
+ TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ NEXT_INST_V(5, numIndices+1, -1);
+ case INST_LSET_LIST: /* 'lset' with 4 args */
/*
* Get the old value of variable, and remove the stack ref. This is
* safe because the variable still references the object; the ref
@@ -3966,31 +4235,21 @@ TclExecuteByteCode(
*/
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
-
- /*
- * Check for errors.
- */
-
- if (objResultPtr) {
- /*
- * Set result.
- */
-
- TRACE(("=> %s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, -1);
- } else {
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- }
- case INST_LIST_RANGE_IMM: {
- /*** lrange with objc==4 and both indices in bytecode stream ***/
+ /*
+ * Set result.
+ */
+
+ TRACE(("=> %s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, -1);
- int listc, fromIdx, toIdx;
- Tcl_Obj **listv, *valuePtr;
+ case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
+ * bytecode stream */
/*
* Pop the list and get the indices.
@@ -4004,44 +4263,43 @@ TclExecuteByteCode(
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
+
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
+ fromIdx, toIdx), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
*/
- if (result == TCL_OK) {
#ifndef TCL_COMPILE_DEBUG
- if (*(pc+9) == INST_POP) {
- NEXT_INST_F(10, 1, 0);
- }
-#endif
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
- fromIdx, toIdx), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ if (*(pc+9) == INST_POP) {
+ NEXT_INST_F(10, 1, 0);
}
+#endif
/*
* Adjust the indices for end-based handling.
*/
if (fromIdx < -1) {
- fromIdx += 1+listc;
+ fromIdx += 1+objc;
if (fromIdx < -1) {
fromIdx = -1;
}
- } else if (fromIdx > listc) {
- fromIdx = listc;
+ } else if (fromIdx > objc) {
+ fromIdx = objc;
}
if (toIdx < -1) {
- toIdx += 1+listc;
+ toIdx += 1 + objc;
if (toIdx < -1) {
toIdx = -1;
}
- } else if (toIdx > listc) {
- toIdx = listc;
+ } else if (toIdx > objc) {
+ toIdx = objc;
}
/*
@@ -4049,14 +4307,14 @@ TclExecuteByteCode(
* so, build the list of elements in that range.
*/
- if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) {
+ if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) {
if (fromIdx<0) {
fromIdx = 0;
}
- if (toIdx >= listc) {
- toIdx = listc-1;
+ if (toIdx >= objc) {
+ toIdx = objc-1;
}
- objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx);
+ objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
} else {
TclNewObj(objResultPtr);
}
@@ -4064,56 +4322,47 @@ TclExecuteByteCode(
TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr),
TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr);
NEXT_INST_F(9, 1, 1);
- }
case INST_LIST_IN:
- case INST_LIST_NOT_IN: {
- /*
- * Basic list containment operators.
- */
-
- int found, s1len, s2len, llen, i;
- Tcl_Obj *valuePtr, *value2Ptr, *o;
- char *s1;
- const char *s2;
-
+ case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
- /* TODO: Consider more efficient tests than strcmp() */
s1 = TclGetStringFromObj(valuePtr, &s1len);
- result = TclListObjLength(interp, value2Ptr, &llen);
- if (result != TCL_OK) {
+ if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
}
- found = 0;
- if (llen > 0) {
+ match = 0;
+ if (length > 0) {
+ int i = 0;
+ Tcl_Obj *o;
+
/*
* An empty list doesn't match anything.
*/
- i = 0;
do {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
if (o != NULL) {
s2 = TclGetStringFromObj(o, &s2len);
} else {
s2 = "";
+ s2len = 0;
}
if (s1len == s2len) {
- found = (strcmp(s1, s2) == 0);
+ match = (memcmp(s1, s2, s1len) == 0);
}
i++;
- } while (i < llen && found == 0);
+ } while (i < length && match == 0);
}
if (*pc == INST_LIST_NOT_IN) {
- found = !found;
+ match = !match;
}
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found));
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
@@ -4125,150 +4374,111 @@ TclExecuteByteCode(
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
- NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
- NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
- NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
- NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
- objResultPtr = constants[found];
+ objResultPtr = TCONST(match);
NEXT_INST_F(0, 2, 1);
- }
/*
* End of INST_LIST and related instructions.
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
+ * Start of string-related instructions.
*/
case INST_STR_EQ:
- case INST_STR_NEQ: {
- /*
- * String (in)equality check
- * TODO: Consider merging into INST_STR_CMP
- */
-
- int iResult;
- Tcl_Obj *valuePtr, *value2Ptr;
-
+ case INST_STR_NEQ: /* String (in)equality check */
+ case INST_STR_CMP: /* String compare. */
+ stringCompare:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
if (valuePtr == value2Ptr) {
+ match = 0;
+ } else {
/*
- * On the off-chance that the objects are the same, we don't
- * really have to think hard about equality.
+ * We only need to check (in)equality when we have equal length
+ * strings. We can use memcmp in all (n)eq cases because we
+ * don't need to worry about lexical LE/BE variance.
*/
- iResult = (*pc == INST_STR_EQ);
- } else {
- char *s1, *s2;
- int s1len, s2len;
-
- s1 = TclGetStringFromObj(valuePtr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- if (s1len == s2len) {
+ typedef int (*memCmpFn_t)(const void*, const void*, size_t);
+ memCmpFn_t memCmpFn;
+ int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
+ || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
+
+ if (TclIsPureByteArray(valuePtr)
+ && TclIsPureByteArray(value2Ptr)) {
+ s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
+ s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+ memCmpFn = memcmp;
+ } else if (((valuePtr->typePtr == &tclStringType)
+ && (value2Ptr->typePtr == &tclStringType))) {
/*
- * We only need to check (in)equality when we have equal
- * length strings.
+ * Do a unicode-specific comparison if both of the args are of
+ * String type. If the char length == byte length, we can do a
+ * memcmp. In benchmark testing this proved the most efficient
+ * check between the unicode and string comparison operations.
*/
- if (*pc == INST_STR_NEQ) {
- iResult = (strcmp(s1, s2) != 0);
+ s1len = Tcl_GetCharLength(valuePtr);
+ s2len = Tcl_GetCharLength(value2Ptr);
+ if ((s1len == valuePtr->length)
+ && (s2len == value2Ptr->length)) {
+ s1 = valuePtr->bytes;
+ s2 = value2Ptr->bytes;
+ memCmpFn = memcmp;
} else {
- /* INST_STR_EQ */
- iResult = (strcmp(s1, s2) == 0);
+ s1 = (char *) Tcl_GetUnicode(valuePtr);
+ s2 = (char *) Tcl_GetUnicode(value2Ptr);
+ if (
+#ifdef WORDS_BIGENDIAN
+ 1
+#else
+ checkEq
+#endif
+ ) {
+ memCmpFn = memcmp;
+ s1len *= sizeof(Tcl_UniChar);
+ s2len *= sizeof(Tcl_UniChar);
+ } else {
+ memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
+ }
}
} else {
- iResult = (*pc == INST_STR_NEQ);
- }
- }
-
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
-
- /*
- * Peep-hole optimisation: if you're about to jump, do jump from here.
- */
-
- pc++;
-#ifndef TCL_COMPILE_DEBUG
- switch (*pc) {
- case INST_JUMP_FALSE1:
- NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
- case INST_JUMP_TRUE1:
- NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
- case INST_JUMP_FALSE4:
- NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
- case INST_JUMP_TRUE4:
- NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
- }
-#endif
- objResultPtr = constants[iResult];
- NEXT_INST_F(0, 2, 1);
- }
-
- case INST_STR_CMP: {
- /*
- * String compare.
- */
-
- const char *s1, *s2;
- int s1len, s2len, iResult;
- Tcl_Obj *valuePtr, *value2Ptr;
-
- stringCompare:
- value2Ptr = OBJ_AT_TOS;
- valuePtr = OBJ_UNDER_TOS;
-
- /*
- * The comparison function should compare up to the minimum byte
- * length only.
- */
-
- if (valuePtr == value2Ptr) {
- /*
- * In the pure equality case, set lengths too for the checks below
- * (or we could goto beyond it).
- */
+ /*
+ * strcmp can't do a simple memcmp in order to handle the
+ * special Tcl \xC0\x80 null encoding for utf-8.
+ */
- iResult = s1len = s2len = 0;
- } else if ((valuePtr->typePtr == &tclByteArrayType)
- && (value2Ptr->typePtr == &tclByteArrayType)) {
- s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
- s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
- iResult = memcmp(s1, s2,
- (size_t) ((s1len < s2len) ? s1len : s2len));
- } else if (((valuePtr->typePtr == &tclStringType)
- && (value2Ptr->typePtr == &tclStringType))) {
- /*
- * Do a unicode-specific comparison if both of the args are of
- * String type. If the char length == byte length, we can do a
- * memcmp. In benchmark testing this proved the most efficient
- * check between the unicode and string comparison operations.
- */
+ s1 = TclGetStringFromObj(valuePtr, &s1len);
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ if (checkEq) {
+ memCmpFn = memcmp;
+ } else {
+ memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
+ }
+ }
- s1len = Tcl_GetCharLength(valuePtr);
- s2len = Tcl_GetCharLength(value2Ptr);
- if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
- iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
- (unsigned) ((s1len < s2len) ? s1len : s2len));
+ if (checkEq && (s1len != s2len)) {
+ match = 1;
} else {
- iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
- Tcl_GetUnicode(value2Ptr),
- (unsigned) ((s1len < s2len) ? s1len : s2len));
+ /*
+ * The comparison function should compare up to the minimum
+ * byte length only.
+ */
+ match = memCmpFn(s1, s2,
+ (size_t) ((s1len < s2len) ? s1len : s2len));
+ if (match == 0) {
+ match = s1len - s2len;
+ }
}
- } else {
- /*
- * We can't do a simple memcmp in order to handle the special Tcl
- * \xC0\x80 null encoding for utf-8.
- */
-
- s1 = TclGetStringFromObj(valuePtr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- iResult = TclpUtfNcmp2(s1, s2,
- (size_t) ((s1len < s2len) ? s1len : s2len));
}
/*
@@ -4276,133 +4486,90 @@ TclExecuteByteCode(
* TODO: consider peephole opt.
*/
- if (iResult == 0) {
- iResult = s1len - s2len;
- }
-
if (*pc != INST_STR_CMP) {
/*
* Take care of the opcodes that goto'ed into here.
*/
switch (*pc) {
+ case INST_STR_EQ:
case INST_EQ:
- iResult = (iResult == 0);
+ match = (match == 0);
break;
+ case INST_STR_NEQ:
case INST_NEQ:
- iResult = (iResult != 0);
+ match = (match != 0);
break;
case INST_LT:
- iResult = (iResult < 0);
+ match = (match < 0);
break;
case INST_GT:
- iResult = (iResult > 0);
+ match = (match > 0);
break;
case INST_LE:
- iResult = (iResult <= 0);
+ match = (match <= 0);
break;
case INST_GE:
- iResult = (iResult >= 0);
+ match = (match >= 0);
break;
}
}
- if (iResult < 0) {
+ if (match < 0) {
TclNewIntObj(objResultPtr, -1);
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
} else {
- objResultPtr = constants[(iResult>0)];
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
- (iResult > 0)));
+ objResultPtr = TCONST(match > 0);
}
-
+ TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
+ O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
-
- case INST_STR_LEN: {
- int length;
- Tcl_Obj *valuePtr;
+ case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
-
- if (valuePtr->typePtr == &tclByteArrayType) {
- (void) Tcl_GetByteArrayFromObj(valuePtr, &length);
- } else {
- length = Tcl_GetCharLength(valuePtr);
- }
+ length = Tcl_GetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
- }
-
- case INST_STR_INDEX: {
- /*
- * String compare.
- */
-
- int index, length;
- char *bytes;
- Tcl_Obj *valuePtr, *value2Ptr;
- bytes = NULL; /* lint */
+ case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/*
- * If we have a ByteArray object, avoid indexing in the Utf string
- * since the byte array contains one byte per character. Otherwise,
- * use the Unicode string rep to get the index'th char.
+ * Get char length to calulate what 'end' means.
*/
- if (valuePtr->typePtr == &tclByteArrayType) {
- bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
- } else {
- /*
- * Get Unicode char length to calulate what 'end' means.
- */
-
- length = Tcl_GetCharLength(valuePtr);
+ length = Tcl_GetCharLength(valuePtr);
+ if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ goto gotError;
}
- result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
- if (result != TCL_OK) {
- goto checkForCatch;
- }
-
- if ((index >= 0) && (index < length)) {
- if (valuePtr->typePtr == &tclByteArrayType) {
- objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
- (&bytes[index]), 1);
- } else if (valuePtr->bytes && length == valuePtr->length) {
- objResultPtr = Tcl_NewStringObj((const char *)
- (&valuePtr->bytes[index]), 1);
- } else {
- char buf[TCL_UTF_MAX];
- Tcl_UniChar ch;
-
- ch = Tcl_GetUniChar(valuePtr, index);
+ if ((index < 0) || (index >= length)) {
+ TclNewObj(objResultPtr);
+ } else if (TclIsPureByteArray(valuePtr)) {
+ objResultPtr = Tcl_NewByteArrayObj(
+ Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1);
+ } else if (valuePtr->bytes && length == valuePtr->length) {
+ objResultPtr = Tcl_NewStringObj((const char *)
+ valuePtr->bytes+index, 1);
+ } else {
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
- /*
- * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch,
- * 1) but creating the object as a string seems to be faster
- * in practical use.
- */
+ /*
+ * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
+ * but creating the object as a string seems to be faster in
+ * practical use.
+ */
- length = Tcl_UniCharToUtf(ch, buf);
- objResultPtr = Tcl_NewStringObj(buf, length);
- }
- } else {
- TclNewObj(objResultPtr);
+ length = Tcl_UniCharToUtf(ch, buf);
+ objResultPtr = Tcl_NewStringObj(buf, length);
}
TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
-
- case INST_STR_MATCH: {
- int nocase, match;
- Tcl_Obj *valuePtr, *value2Ptr;
+ case INST_STR_MATCH:
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
@@ -4415,19 +4582,17 @@ TclExecuteByteCode(
if ((valuePtr->typePtr == &tclStringType)
|| (value2Ptr->typePtr == &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
- int length1, length2;
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
- match = TclUniCharMatch(ustring1, length1, ustring2, length2,
+ match = TclUniCharMatch(ustring1, length, ustring2, length2,
nocase);
- } else if ((valuePtr->typePtr == &tclByteArrayType) && !nocase) {
- unsigned char *string1, *string2;
- int length1, length2;
+ } else if (TclIsPureByteArray(valuePtr) && !nocase) {
+ unsigned char *bytes1, *bytes2;
- string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1);
- string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
- match = TclByteArrayMatch(string1, length1, string2, length2, 0);
+ bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length);
+ bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
+ match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
@@ -4436,64 +4601,105 @@ TclExecuteByteCode(
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
- * TODO: consider peephole opt.
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
- objResultPtr = constants[match];
- NEXT_INST_F(2, 2, 1);
- }
- case INST_REGEXP: {
- int cflags, match;
- Tcl_Obj *valuePtr, *value2Ptr;
- Tcl_RegExp regExpr;
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ */
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = TCONST(match);
+ NEXT_INST_F(0, 2, 1);
+
+ case INST_REGEXP:
cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
- regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
- if (regExpr == NULL) {
- match = -1;
- } else {
+ /*
+ * Compile and match the regular expression.
+ */
+
+ {
+ Tcl_RegExp regExpr =
+ Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
+
+ if (regExpr == NULL) {
+ goto regexpFailure;
+ }
+
match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
+
+ if (match < 0) {
+ regexpFailure:
+#ifdef TCL_COMPILE_DEBUG
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
+ O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+#endif
+ goto gotError;
+ }
}
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+
/*
- * Adjustment is 2 due to the nocase byte
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ * Adjustment is 2 due to the nocase byte.
*/
- if (match < 0) {
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
- O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- } else {
- TRACE(("%.20s %.20s => %d\n",
- O2S(valuePtr), O2S(value2Ptr), match));
- objResultPtr = constants[match];
- NEXT_INST_F(2, 2, 1);
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
+#endif
+ objResultPtr = TCONST(match);
+ NEXT_INST_F(0, 2, 1);
}
+ /*
+ * End of string-related instructions.
+ * -----------------------------------------------------------------
+ * Start of numeric operator instructions.
+ */
+
+ {
+ ClientData ptr1, ptr2;
+ int type1, type2;
+ long l1, l2, lResult;
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE: {
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- ClientData ptr1, ptr2;
- int iResult = 0, compare = 0, type1, type2;
- double d1, d2, tmp;
- long l1, l2;
- mp_int big1, big2;
-#ifndef NO_WIDE_TYPE
- Tcl_WideInt w1, w2;
-#endif
+ int iResult = 0, compare = 0;
+
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
/*
@@ -4529,222 +4735,12 @@ TclExecuteByteCode(
iResult = (*pc == INST_NEQ);
goto foundResult;
}
- switch (type1) {
- case TCL_NUMBER_LONG:
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
l1 = *((const long *)ptr1);
- switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- longCompare:
- compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- w1 = (Tcl_WideInt)l1;
- goto wideCompare;
-#endif
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) l1;
-
- /*
- * If the double has a fractional part, or if the long can be
- * converted to double without loss of precision, then compare
- * as doubles.
- */
-
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- || l1 == (long) d1
- || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
-
- /*
- * Otherwise, to make comparision based on full precision,
- * need to convert the double to a suitably sized integer.
- *
- * Need this to get comparsions like
- * expr 20000000000000003 < 20000000000000004.0
- * right. Converting the first argument to double will yield
- * two double values that are equivalent within double
- * precision. Converting the double to an integer gets done
- * exactly, then integer comparison can tell the difference.
- */
-
- if (d2 < (double)LONG_MIN) {
- compare = MP_GT;
- break;
- }
- if (d2 > (double)LONG_MAX) {
- compare = MP_LT;
- break;
- }
- l2 = (long) d2;
- goto longCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- }
- break;
-
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *)ptr1);
- switch (type2) {
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- wideCompare:
- compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
- break;
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- w2 = (Tcl_WideInt)l2;
- goto wideCompare;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) w1;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w1 == (Tcl_WideInt) d1
- || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d2 < (double)LLONG_MIN) {
- compare = MP_GT;
- break;
- }
- if (d2 > (double)LLONG_MAX) {
- compare = MP_LT;
- break;
- }
- w2 = (Tcl_WideInt) d2;
- goto wideCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- }
- break;
-#endif
-
- case TCL_NUMBER_DOUBLE:
- d1 = *((const double *)ptr1);
- switch (type2) {
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- doubleCompare:
- compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
- break;
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- d2 = (double) l2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- || l2 == (long) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LONG_MIN) {
- compare = MP_LT;
- break;
- }
- if (d1 > (double)LONG_MAX) {
- compare = MP_GT;
- break;
- }
- l1 = (long) d1;
- goto longCompare;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- d2 = (double) w2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w2 == (Tcl_WideInt) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LLONG_MIN) {
- compare = MP_LT;
- break;
- }
- if (d1 > (double)LLONG_MAX) {
- compare = MP_GT;
- break;
- }
- w1 = (Tcl_WideInt) d1;
- goto wideCompare;
-#endif
- case TCL_NUMBER_BIG:
- if (TclIsInfinite(d1)) {
- compare = (d1 > 0.0) ? MP_GT : MP_LT;
- break;
- }
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- break;
- }
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- && modf(d1, &tmp) != 0.0) {
- d2 = TclBignumToDouble(&big2);
- mp_clear(&big2);
- goto doubleCompare;
- }
- Tcl_InitBignumFromDouble(NULL, d1, &big1);
- goto bigCompare;
- }
- break;
-
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- switch (type2) {
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
-#endif
- case TCL_NUMBER_LONG:
- compare = mp_cmp_d(&big1, 0);
- mp_clear(&big1);
- break;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- if (TclIsInfinite(d2)) {
- compare = (d2 > 0.0) ? MP_LT : MP_GT;
- mp_clear(&big1);
- break;
- }
- if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
- compare = mp_cmp_d(&big1, 0);
- mp_clear(&big1);
- break;
- }
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- && modf(d2, &tmp) != 0.0) {
- d1 = TclBignumToDouble(&big1);
- mp_clear(&big1);
- goto doubleCompare;
- }
- Tcl_InitBignumFromDouble(NULL, d2, &big2);
- goto bigCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- bigCompare:
- compare = mp_cmp(&big1, &big2);
- mp_clear(&big1);
- mp_clear(&big2);
- }
+ l2 = *((const long *)ptr2);
+ compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ } else {
+ compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
}
/*
@@ -4791,745 +4787,257 @@ TclExecuteByteCode(
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
- objResultPtr = constants[iResult];
+ objResultPtr = TCONST(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
- case INST_RSHIFT: {
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- ClientData ptr1, ptr2;
- int invalid, shift, type1, type2;
- long l1 = 0;
+ case INST_RSHIFT:
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
- result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
- if ((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE)
- || (type1 == TCL_NUMBER_NAN)) {
- result = TCL_ERROR;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
- result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
- if ((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE)
- || (type2 == TCL_NUMBER_NAN)) {
- result = TCL_ERROR;
+ if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
+ || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
- if (*pc == INST_MOD) {
- /* TODO: Attempts to re-use unshared operands on stack */
+ /*
+ * Check for common, simple case.
+ */
- long l2 = 0; /* silence gcc warning */
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
+ l1 = *((const long *)ptr1);
+ l2 = *((const long *)ptr2);
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *)ptr2);
+ switch (*pc) {
+ case INST_MOD:
if (l2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto divideByZero;
- }
- if ((l2 == 1) || (l2 == -1)) {
+ } else if ((l2 == 1) || (l2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
- objResultPtr = constants[0];
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
- }
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
- if (l1 == 0) {
+ } else if (l1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
- objResultPtr = constants[0];
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
- if (type2 == TCL_NUMBER_LONG) {
- /*
- * Both operands are long; do native calculation.
- */
-
- long lRemainder, lQuotient = l1 / l2;
+ } else {
+ lResult = l1 / l2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if ((lQuotient < 0 || (lQuotient == 0 &&
+ if ((lResult < 0 || (lResult == 0 &&
((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- (lQuotient * l2 != l1)) {
- lQuotient -= 1;
+ (lResult * l2 != l1)) {
+ lResult -= 1;
}
- lRemainder = l1 - l2*lQuotient;
- TclNewLongObj(objResultPtr, lRemainder);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
+ lResult = l1 - l2*lResult;
+ goto longResultOfArithmetic;
}
- /*
- * First operand fits in long; second does not, so the second
- * has greater magnitude than first. No need to divide to
- * determine the remainder.
- */
-
-#ifndef NO_WIDE_TYPE
- if (type2 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
-
- if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) {
- /*
- * Arguments are opposite sign; remainder is sum.
- */
-
- objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Arguments are same sign; remainder is first operand.
- */
-
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
+ case INST_RSHIFT:
+ if (l2 < 0) {
+ Tcl_SetResult(interp, "negative shift argument",
+ TCL_STATIC);
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "domain error: argument not in valid range",
+ NULL);
+ CACHE_STACK_INFO();
#endif
- {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
-
- /* TODO: internals intrusion */
- if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) {
- /*
- * Arguments are opposite sign; remainder is sum.
- */
-
- mp_int big1;
-
- TclBNInitBignumFromLong(&big1, l1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
- objResultPtr = Tcl_NewBignumObj(&big2);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Arguments are same sign; remainder is first operand.
- */
-
- mp_clear(&big2);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#ifndef NO_WIDE_TYPE
- if (type1 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1);
-
- if (type2 != TCL_NUMBER_BIG) {
- Tcl_WideInt w2, wQuotient, wRemainder;
-
- Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
- wQuotient = w1 / w2;
-
- /*
- * Force Tcl's integer division rules.
- * TODO: examine for logic simplification
- */
-
- if (((wQuotient < (Tcl_WideInt) 0)
- || ((wQuotient == (Tcl_WideInt) 0)
- && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
- || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
- && (wQuotient * w2 != w1)) {
- wQuotient -= (Tcl_WideInt) 1;
- }
- wRemainder = w1 - w2*wQuotient;
- objResultPtr = Tcl_NewWideIntObj(wRemainder);
+ goto gotError;
+ } else if (l1 == 0) {
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
- {
- mp_int big2;
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ /*
+ * Quickly force large right shifts to 0 or -1.
+ */
- /* TODO: internals intrusion */
- if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) {
+ if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
/*
- * Arguments are opposite sign; remainder is sum.
+ * We assume that INT_MAX is much larger than the
+ * number of bits in a long. This is a pretty safe
+ * assumption, given that the former is usually around
+ * 4e9 and the latter 32 or 64...
*/
- mp_int big1;
-
- TclBNInitBignumFromWideInt(&big1, w1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
- objResultPtr = Tcl_NewBignumObj(&big2);
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (l1 > 0L) {
+ objResultPtr = TCONST(0);
+ } else {
+ TclNewIntObj(objResultPtr, -1);
+ }
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
/*
- * Arguments are same sign; remainder is first operand.
+ * Handle shifts within the native long range.
*/
- mp_clear(&big2);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
+ lResult = l1 >> ((int) l2);
+ goto longResultOfArithmetic;
}
- }
-#endif
- {
- mp_int big1, big2, bigResult, bigRemainder;
-
- Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
- Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- if (!mp_iszero(&bigRemainder)
- && (bigRemainder.sign != big2.sign)) {
- /*
- * Convert to Tcl's integer division rules.
- */
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
- }
- mp_copy(&bigRemainder, &bigResult);
- mp_clear(&bigRemainder);
- mp_clear(&big1);
- mp_clear(&big2);
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-
- /*
- * Reject negative shift argument.
- */
-
- switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < (long)0);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
- break;
+ case INST_LSHIFT:
+ if (l2 < 0) {
+ Tcl_SetResult(interp, "negative shift argument",
+ TCL_STATIC);
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "domain error: argument not in valid range",
+ NULL);
+ CACHE_STACK_INFO();
#endif
- case TCL_NUMBER_BIG: {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- invalid = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_clear(&big2);
- break;
- }
- default:
- /* Unused, here to silence compiler warning */
- invalid = 0;
- }
- if (invalid) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("negative shift argument", -1));
- result = TCL_ERROR;
- goto checkForCatch;
- }
-
- /*
- * Zero shifted any number of bits is still zero.
- */
-
- if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = constants[0];
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- if (*pc == INST_LSHIFT) {
- /*
- * Large left shifts create integer overflow.
- *
- * BEWARE! Can't use Tcl_GetIntFromObj() here because that
- * converts values in the (unsigned) range to their signed int
- * counterparts, leading to incorrect results.
- */
-
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (long) INT_MAX)) {
- /*
- * Technically, we could hold the value (1 << (INT_MAX+1)) in
- * an mp_int, but since we're using mp_mul_2d() to do the
- * work, and it takes only an int argument, that's a good
- * place to draw the line.
- */
-
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent", -1));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- shift = (int)(*((const long *)ptr2));
-
- /*
- * Handle shifts within the native long range.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type1 == TCL_NUMBER_LONG)
- && (size_t) shift < CHAR_BIT*sizeof(long)
- && ((l1 = *(const long *)ptr1) != 0)
- && !((l1>0 ? l1 : ~l1)
- & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- TclNewLongObj(objResultPtr, (l1<<shift));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Handle shifts within the native wide range.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type1 != TCL_NUMBER_BIG)
- && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
- Tcl_WideInt w;
-
- TclGetWideIntFromObj(NULL, valuePtr, &w);
- if (!((w>0 ? w : ~w)
- & -(((Tcl_WideInt)1)
- << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
- objResultPtr = Tcl_NewWideIntObj(w<<shift);
+ goto gotError;
+ } else if (l1 == 0) {
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
- }
- } else {
- /*
- * Quickly force large right shifts to 0 or -1.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type2 != TCL_NUMBER_LONG)
- || (*(const long *)ptr2 > INT_MAX)) {
- /*
- * Again, technically, the value to be shifted could be an
- * mp_int so huge that a right shift by (INT_MAX+1) bits could
- * not take us to the result of 0 or -1, but since we're using
- * mp_div_2d to do the work, and it takes only an int
- * argument, we draw the line there.
- */
-
- int zero;
-
- switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
- break;
-#endif
- case TCL_NUMBER_BIG: {
- mp_int big1;
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- zero = (mp_cmp_d(&big1, 0) == MP_GT);
- mp_clear(&big1);
- break;
- }
- default:
- /* Unused, here to silence compiler warning. */
- zero = 0;
- }
- if (zero) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- shift = (int)(*(const long *)ptr2);
-
- /*
- * Handle shifts within the native long range.
- */
-
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
- if ((size_t)shift >= CHAR_BIT*sizeof(long)) {
- if (l1 >= (long)0) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- } else {
- TclNewLongObj(objResultPtr, (l1 >> shift));
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
-#ifndef NO_WIDE_TYPE
- /*
- * Handle shifts within the native wide range.
- */
-
- if (type1 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *(const Tcl_WideInt *)ptr1;
-
- if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
- if (w >= (Tcl_WideInt)0) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- } else {
- objResultPtr = Tcl_NewWideIntObj(w >> shift);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#endif
- }
-
- {
- mp_int big, bigResult, bigRemainder;
-
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
-
- mp_init(&bigResult);
- if (*pc == INST_LSHIFT) {
- mp_mul_2d(&big, shift, &bigResult);
- } else {
- mp_init(&bigRemainder);
- mp_div_2d(&big, shift, &bigResult, &bigRemainder);
- if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
+ } else if (l2 > (long) INT_MAX) {
/*
- * Convert to Tcl's integer division rules.
+ * Technically, we could hold the value (1 << (INT_MAX+1))
+ * in an mp_int, but since we're using mp_mul_2d() to do
+ * the work, and it takes only an int argument, that's a
+ * good place to draw the line.
*/
- mp_sub_d(&bigResult, 1, &bigResult);
- }
- mp_clear(&bigRemainder);
- }
- mp_clear(&big);
-
- if (!Tcl_IsShared(valuePtr)) {
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- case INST_BITOR:
- case INST_BITXOR:
- case INST_BITAND: {
- ClientData ptr1, ptr2;
- int type1, type2;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
-
- result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
- if ((result != TCL_OK)
- || (type1 == TCL_NUMBER_NAN)
- || (type1 == TCL_NUMBER_DOUBLE)) {
- result = TCL_ERROR;
- TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
- O2S(value2Ptr), (valuePtr->typePtr?
- valuePtr->typePtr->name : "null")));
- DECACHE_STACK_INFO();
- IllegalExprOperandType(interp, pc, valuePtr);
- CACHE_STACK_INFO();
- goto checkForCatch;
- }
- result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
- if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN)
- || (type2 == TCL_NUMBER_DOUBLE)) {
- result = TCL_ERROR;
- TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
- O2S(value2Ptr), (value2Ptr->typePtr?
- value2Ptr->typePtr->name : "null")));
- DECACHE_STACK_INFO();
- IllegalExprOperandType(interp, pc, value2Ptr);
- CACHE_STACK_INFO();
- goto checkForCatch;
- }
-
- if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
- mp_int big1, big2, bigResult, *First, *Second;
- int numPos;
-
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
-
- /*
- * Count how many positive arguments we have. If only one of the
- * arguments is negative, store it in 'Second'.
- */
-
- if (mp_cmp_d(&big1, 0) != MP_LT) {
- numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT);
- First = &big1;
- Second = &big2;
- } else {
- First = &big2;
- Second = &big1;
- numPos = (mp_cmp_d(First, 0) != MP_LT);
- }
- mp_init(&bigResult);
-
- switch (*pc) {
- case INST_BITAND:
- switch (numPos) {
- case 2:
- /*
- * Both arguments positive, base case.
- */
-
- mp_and(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1))
- */
-
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- mp_and(First, &bigResult, &bigResult);
- break;
- case 0:
- /*
- * Both arguments negative:
- * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1
- */
-
- mp_neg(First, First);
- mp_sub_d(First, 1, First);
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_or(First, Second, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- }
- break;
-
- case INST_BITOR:
- switch (numPos) {
- case 2:
- /*
- * Both arguments positive, base case.
- */
-
- mp_or(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1
- */
-
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- mp_and(Second, &bigResult, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- case 0:
- /*
- * Both arguments negative:
- * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1
- */
-
- mp_neg(First, First);
- mp_sub_d(First, 1, First);
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_and(First, Second, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- }
- break;
-
- case INST_BITXOR:
- switch (numPos) {
- case 2:
- /*
- * Both arguments positive, base case.
- */
-
- mp_xor(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * P^N = ~(P^~N) = -(P^(-N-1))-1
- */
+ Tcl_SetResult(interp,
+ "integer value too large to represent",
+ TCL_STATIC);
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent", NULL);
+ CACHE_STACK_INFO();
+#endif
+ goto gotError;
+ } else {
+ int shift = (int) l2;
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- case 0:
/*
- * Both arguments negative:
- * a ^ b = (~a ^ ~b) = (-a-1^-b-1)
+ * Handle shifts within the native long range.
*/
- mp_neg(First, First);
- mp_sub_d(First, 1, First);
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- break;
+ if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0)
+ && !((l1>0 ? l1 : ~l1) &
+ -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
+ lResult = l1 << shift;
+ goto longResultOfArithmetic;
+ }
}
- break;
- }
- mp_clear(&big1);
- mp_clear(&big2);
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-
-#ifndef NO_WIDE_TYPE
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
- Tcl_WideInt wResult, w1, w2;
-
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+ /*
+ * Too large; need to use the broken-out function.
+ */
- switch (*pc) {
- case INST_BITAND:
- wResult = w1 & w2;
- break;
- case INST_BITOR:
- wResult = w1 | w2;
- break;
- case INST_BITXOR:
- wResult = w1 ^ w2;
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
break;
- default:
- /* Unused, here to silence compiler warning. */
- wResult = 0;
- }
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-#endif
- {
- long lResult, l1 = *((const long *)ptr1);
- long l2 = *((const long *)ptr2);
-
- switch (*pc) {
case INST_BITAND:
lResult = l1 & l2;
- break;
+ goto longResultOfArithmetic;
case INST_BITOR:
lResult = l1 | l2;
- break;
+ goto longResultOfArithmetic;
case INST_BITXOR:
lResult = l1 ^ l2;
- break;
- default:
- /* Unused, here to silence compiler warning. */
- lResult = 0;
+ longResultOfArithmetic:
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ TclNewLongObj(objResultPtr, lResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ TclSetLongObj(valuePtr, lResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
}
+ }
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
+ /*
+ * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would
+ * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which
+ * is highly undesirable due to the overall impact on size.
+ */
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
+ valuePtr, value2Ptr);
+ if (objResultPtr == DIVIDED_BY_ZERO) {
+ TRACE_APPEND(("DIVIDE BY ZERO\n"));
+ goto divideByZero;
+ } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
+ TRACE_APPEND(("ERROR: %s\n",
+ TclGetString(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (objResultPtr == NULL) {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
+ } else {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- }
case INST_EXPON:
case INST_ADD:
case INST_SUB:
case INST_DIV:
- case INST_MULT: {
- ClientData ptr1, ptr2;
- int type1, type2;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
+ case INST_MULT:
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
- result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
- if ((result != TCL_OK)
-#ifndef ACCEPT_NAN
- || (type1 == TCL_NUMBER_NAN)
-#endif
- ) {
- result = TCL_ERROR;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || IsErroringNaNType(type1)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name: "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
#ifdef ACCEPT_NAN
@@ -5542,20 +5050,15 @@ TclExecuteByteCode(
}
#endif
- result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
- if ((result != TCL_OK)
-#ifndef ACCEPT_NAN
- || (type2 == TCL_NUMBER_NAN)
-#endif
- ) {
- result = TCL_ERROR;
+ if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
+ || IsErroringNaNType(type2)) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
#ifdef ACCEPT_NAN
@@ -5569,911 +5072,242 @@ TclExecuteByteCode(
}
#endif
- if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
- /*
- * At least one of the values is floating-point, so perform
- * floating point calculations.
- */
+ /*
+ * Handle (long,long) arithmetic as best we can without going out to
+ * an external function.
+ */
- double d1, d2, dResult;
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
+ Tcl_WideInt w1, w2, wResult;
- Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
- Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
+ l1 = *((const long *)ptr1);
+ l2 = *((const long *)ptr2);
switch (*pc) {
case INST_ADD:
- dResult = d1 + d2;
- break;
- case INST_SUB:
- dResult = d1 - d2;
- break;
- case INST_MULT:
- dResult = d1 * d2;
- break;
- case INST_DIV:
-#ifndef IEEE_FLOATING_POINT
- if (d2 == 0.0) {
- TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
- goto divideByZero;
- }
-#endif
+ w1 = (Tcl_WideInt) l1;
+ w2 = (Tcl_WideInt) l2;
+ wResult = w1 + w2;
+#ifdef NO_WIDE_TYPE
/*
- * We presume that we are running with zero-divide unmasked if
- * we're on an IEEE box. Otherwise, this statement might cause
- * demons to fly out our noses.
+ * Check for overflow.
*/
- dResult = d1 / d2;
- break;
- case INST_EXPON:
- if (d1==0.0 && d2<0.0) {
- TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
- goto exponOfZero;
- }
- dResult = pow(d1, d2);
- break;
- default:
- /* Unused, here to silence compiler warning. */
- dResult = 0;
- }
-
-#ifndef ACCEPT_NAN
- /*
- * Check now for IEEE floating-point error.
- */
-
- if (TclIsNaN(dResult)) {
- TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
- O2S(valuePtr), O2S(value2Ptr)));
- DECACHE_STACK_INFO();
- TclExprFloatError(interp, dResult);
- CACHE_STACK_INFO();
- result = TCL_ERROR;
- goto checkForCatch;
- }
-#endif
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewDoubleObj(objResultPtr, dResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetDoubleObj(valuePtr, dResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-
- if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT)
- && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- long l1 = *((const long *)ptr1);
- long l2 = *((const long *)ptr2);
-
- if ((l1 <= INT_MAX) && (l1 >= INT_MIN)
- && (l2 <= INT_MAX) && (l2 >= INT_MIN)) {
- long lResult = l1 * l2;
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr,lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-
- if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT)
- && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- Tcl_WideInt w1, w2, wResult;
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
-
- wResult = w1 * w2;
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-
- /* TODO: Attempts to re-use unshared operands on stack. */
- if (*pc == INST_EXPON) {
- long l1 = 0, l2 = 0;
- int oddExponent = 0, negativeExponent = 0;
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
- Tcl_WideInt w1;
-#endif
-
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *) ptr2);
- if (l2 == 0) {
- /*
- * Anything to the zero power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- } else if (l2 == 1) {
- /*
- * Anything to the first power is itself
- */
- NEXT_INST_F(1, 1, 0);
+ if (Overflowing(w1, w2, wResult)) {
+ goto overflow;
}
- }
-
- switch (type2) {
- case TCL_NUMBER_LONG: {
- negativeExponent = (l2 < 0);
- oddExponent = (int) (l2 & 1);
- break;
- }
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE: {
- Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
-
- negativeExponent = (w2 < 0);
- oddExponent = (int) (w2 & (Tcl_WideInt)1);
- break;
- }
#endif
- case TCL_NUMBER_BIG: {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_mod_2d(&big2, 1, &big2);
- oddExponent = !mp_iszero(&big2);
- mp_clear(&big2);
- break;
- }
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
- }
- if (negativeExponent) {
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
- case 0:
- /*
- * Zero to a negative power is div by zero error.
- */
-
- TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
- O2S(value2Ptr)));
- goto exponOfZero;
- case -1:
- if (oddExponent) {
- TclNewIntObj(objResultPtr, -1);
- } else {
- objResultPtr = constants[1];
- }
- NEXT_INST_F(1, 2, 1);
- case 1:
- /*
- * 1 to any power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- }
- }
+ goto wideResultOfArithmetic;
+ case INST_SUB:
+ w1 = (Tcl_WideInt) l1;
+ w2 = (Tcl_WideInt) l2;
+ wResult = w1 - w2;
+#ifdef NO_WIDE_TYPE
/*
- * Integers with magnitude greater than 1 raise to a negative
- * power yield the answer zero (see TIP 123).
+ * Must check for overflow. The macro tests for overflows in
+ * sums by looking at the sign bits. As we have a subtraction
+ * here, we are adding -w2. As -w2 could in turn overflow, we
+ * test with ~w2 instead: it has the opposite sign bit to w2
+ * so it does the job. Note that the only "bad" case (w2==0)
+ * is irrelevant for this macro, as in that case w1 and
+ * wResult have the same sign and there is no overflow anyway.
*/
- objResultPtr = constants[0];
- NEXT_INST_F(1, 2, 1);
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
- case 0:
- /*
- * Zero to a positive power is zero.
- */
-
- objResultPtr = constants[0];
- NEXT_INST_F(1, 2, 1);
- case 1:
- /*
- * 1 to any power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- case -1:
- if (oddExponent) {
- TclNewIntObj(objResultPtr, -1);
- } else {
- objResultPtr = constants[1];
- }
- NEXT_INST_F(1, 2, 1);
- }
- }
- /*
- * We refuse to accept exponent arguments that exceed
- * one mp_digit which means the max exponent value is
- * 2**28-1 = 0x0fffffff = 268435455, which fits into
- * a signed 32 bit int which is within the range of the
- * long int type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger
- * than we accept.
- */
- if (type2 != TCL_NUMBER_LONG) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
- result = TCL_ERROR;
- goto checkForCatch;
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- if (l1 == 2) {
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- TclNewLongObj(objResultPtr, (1L << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr =
- Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#endif
- goto overflow;
- }
- if (l1 == -2) {
- int signum = oddExponent ? -1 : 1;
-
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- TclNewLongObj(objResultPtr, signum * (1L << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = Tcl_NewWideIntObj(
- signum * (((Tcl_WideInt) 1) << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#endif
+ if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
-#if (LONG_MAX == 0x7fffffff)
- if (l2 - 2 < (long)MaxBase32Size
- && l1 <= MaxBase32[l2 - 2]
- && l1 >= -MaxBase32[l2 - 2]) {
- /*
- * Small powers of 32-bit integers.
- */
-
- long lResult = l1 * l1; /* b**2 */
- switch (l2) {
- case 2:
- break;
- case 3:
- lResult *= l1; /* b**3 */
- break;
- case 4:
- lResult *= lResult; /* b**4 */
- break;
- case 5:
- lResult *= lResult; /* b**4 */
- lResult *= l1; /* b**5 */
- break;
- case 6:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- break;
- case 7:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- lResult *= l1; /* b**7 */
- break;
- case 8:
- lResult *= lResult; /* b**4 */
- lResult *= lResult; /* b**8 */
- break;
- }
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- if (l1 - 3 >= 0 && l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
-
- unsigned short base = Exp32Index[l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, Exp32Value[base]);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, Exp32Value[base]);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
- if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- unsigned short base = Exp32Index[-l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[-l1 - 2]) {
- long lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
-
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#endif
- }
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
- if (type1 == TCL_NUMBER_LONG) {
- w1 = l1;
-#ifndef NO_WIDE_TYPE
- } else if (type1 == TCL_NUMBER_WIDE) {
- w1 = *((const Tcl_WideInt*) ptr1);
#endif
- } else {
- goto overflow;
- }
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
- /*
- * Small powers of integers whose result is wide.
- */
-
- Tcl_WideInt wResult = w1 * w1; /* b**2 */
-
- switch (l2) {
- case 2:
- break;
- case 3:
- wResult *= l1; /* b**3 */
- break;
- case 4:
- wResult *= wResult; /* b**4 */
- break;
- case 5:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- break;
- case 6:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- break;
- case 7:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- break;
- case 8:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- break;
- case 9:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- wResult *= w1; /* b**9 */
- break;
- case 10:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- wResult *= wResult; /* b**10 */
- break;
- case 11:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- wResult *= wResult; /* b**10 */
- wResult *= w1; /* b**11 */
- break;
- case 12:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= wResult; /* b**12 */
- break;
- case 13:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= wResult; /* b**12 */
- wResult *= w1; /* b**13 */
- break;
- case 14:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- wResult *= wResult; /* b**14 */
- break;
- case 15:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- wResult *= wResult; /* b**14 */
- wResult *= w1; /* b**15 */
- break;
- case 16:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- wResult *= wResult; /* b**16 */
- break;
-
- }
+ wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Handle cases of powers > 16 that still fit in a 64-bit word by
- * doing table lookup.
- */
- if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
- unsigned short base = Exp64Index[w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
-
- if (base < Exp64Index[w1 - 2]) {
- /*
- * 64-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, Exp64Value[base]);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-
- if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
- unsigned short base = Exp64Index[-w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
-
- if (base < Exp64Index[-w1 - 2]) {
- Tcl_WideInt wResult = (oddExponent) ?
- -Exp64Value[base] : Exp64Value[base];
- /*
- * 64-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#endif
-
- goto overflow;
- }
-
- if ((*pc != INST_MULT)
- && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
- Tcl_WideInt w1, w2, wResult;
-
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
-
- switch (*pc) {
- case INST_ADD:
- wResult = w1 + w2;
-#ifndef NO_WIDE_TYPE
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
- {
- /*
- * Check for overflow.
- */
-
- if (Overflowing(w1, w2, wResult)) {
- goto overflow;
- }
- }
- break;
-
- case INST_SUB:
- wResult = w1 - w2;
-#ifndef NO_WIDE_TYPE
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
- {
- /*
- * Must check for overflow. The macro tests for overflows
- * in sums by looking at the sign bits. As we have a
- * subtraction here, we are adding -w2. As -w2 could in
- * turn overflow, we test with ~w2 instead: it has the
- * opposite sign bit to w2 so it does the job. Note that
- * the only "bad" case (w2==0) is irrelevant for this
- * macro, as in that case w1 and wResult have the same
- * sign and there is no overflow anyway.
- */
-
- if (Overflowing(w1, ~w2, wResult)) {
- goto overflow;
- }
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- break;
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
case INST_DIV:
- if (w2 == 0) {
+ if (l2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- }
-
- /*
- * Need a bignum to represent (LLONG_MIN / -1)
- */
+ } else if ((l1 == LONG_MIN) && (l2 == -1)) {
+ /*
+ * Can't represent (-LONG_MIN) as a long.
+ */
- if ((w1 == LLONG_MIN) && (w2 == -1)) {
goto overflow;
}
- wResult = w1 / w2;
+ lResult = l1 / l2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if (((wResult < 0) || ((wResult == 0) &&
- ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
- ((wResult * w2) != w1)) {
- wResult -= 1;
+ if (((lResult < 0) || ((lResult == 0) &&
+ ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
+ ((lResult * l2) != l1)) {
+ lResult -= 1;
}
- break;
- default:
- /*
- * Unused, here to silence compiler warning.
- */
+ goto longResultOfArithmetic;
- wResult = 0;
+ case INST_MULT:
+ if (((sizeof(long) >= 2*sizeof(int))
+ && (l1 <= INT_MAX) && (l1 >= INT_MIN)
+ && (l2 <= INT_MAX) && (l2 >= INT_MIN))
+ || ((sizeof(long) >= 2*sizeof(short))
+ && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN)
+ && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) {
+ lResult = l1 * l2;
+ goto longResultOfArithmetic;
+ }
}
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
+ /*
+ * Fall through with INST_EXPON, INST_DIV and large multiplies.
+ */
}
overflow:
- {
- mp_int big1, big2, bigResult, bigRemainder;
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
- switch (*pc) {
- case INST_ADD:
- mp_add(&big1, &big2, &bigResult);
- break;
- case INST_SUB:
- mp_sub(&big1, &big2, &bigResult);
- break;
- case INST_MULT:
- mp_mul(&big1, &big2, &bigResult);
- break;
- case INST_DIV:
- if (mp_iszero(&big2)) {
- TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
- O2S(value2Ptr)));
- mp_clear(&big1);
- mp_clear(&big2);
- mp_clear(&bigResult);
- goto divideByZero;
- }
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- /* TODO: internals intrusion */
- if (!mp_iszero(&bigRemainder)
- && (bigRemainder.sign != big2.sign)) {
- /*
- * Convert to Tcl's integer division rules.
- */
-
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
- }
- mp_clear(&bigRemainder);
- break;
- case INST_EXPON:
- if (big2.used > 1) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
- mp_clear(&big1);
- mp_clear(&big2);
- mp_clear(&bigResult);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- mp_expt_d(&big1, big2.dp[0], &bigResult);
- break;
- }
- mp_clear(&big1);
- mp_clear(&big2);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
+ valuePtr, value2Ptr);
+ if (objResultPtr == DIVIDED_BY_ZERO) {
+ TRACE_APPEND(("DIVIDE BY ZERO\n"));
+ goto divideByZero;
+ } else if (objResultPtr == EXPONENT_OF_ZERO) {
+ TRACE_APPEND(("EXPONENT OF ZERO\n"));
+ goto exponOfZero;
+ } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
+ TRACE_APPEND(("ERROR: %s\n",
+ TclGetString(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (objResultPtr == NULL) {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
+ } else {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- }
case INST_LNOT: {
int b;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
+
+ valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
- result = TclGetBooleanFromObj(NULL, valuePtr, &b);
- if (result != TCL_OK) {
+ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
/* TODO: Consider peephole opt. */
- objResultPtr = constants[!b];
+ objResultPtr = TCONST(!b);
NEXT_INST_F(1, 1, 1);
}
- case INST_BITNOT: {
- mp_int big;
- ClientData ptr;
- int type;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
-
- result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
- if ((result != TCL_OK)
- || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
+ case INST_BITNOT:
+ valuePtr = OBJ_AT_TOS;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
/*
* ... ~$NonInteger => raise an error.
*/
- result = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
- if (type == TCL_NUMBER_LONG) {
- long l = *((const long *)ptr);
-
+ if (type1 == TCL_NUMBER_LONG) {
+ l1 = *((const long *) ptr1);
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, ~l);
+ TclNewLongObj(objResultPtr, ~l1);
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, ~l);
+ TclSetLongObj(valuePtr, ~l1);
NEXT_INST_F(1, 0, 0);
}
-#ifndef NO_WIDE_TYPE
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *((const Tcl_WideInt *)ptr);
-
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(~w);
- NEXT_INST_F(1, 1, 1);
- }
- Tcl_SetWideIntObj(valuePtr, ~w);
- NEXT_INST_F(1, 0, 0);
- }
-#endif
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
- /* ~a = - a - 1 */
- mp_neg(&big, &big);
- mp_sub_d(&big, 1, &big);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&big);
+ objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
+ if (objResultPtr != NULL) {
NEXT_INST_F(1, 1, 1);
+ } else {
+ NEXT_INST_F(1, 0, 0);
}
- Tcl_SetBignumObj(valuePtr, &big);
- NEXT_INST_F(1, 0, 0);
- }
- case INST_UMINUS: {
- ClientData ptr;
- int type;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
-
- result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
- if ((result != TCL_OK)
-#ifndef ACCEPT_NAN
- || (type == TCL_NUMBER_NAN)
-#endif
- ) {
- result = TCL_ERROR;
+ case INST_UMINUS:
+ valuePtr = OBJ_AT_TOS;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || IsErroringNaNType(type1)) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
- switch (type) {
- case TCL_NUMBER_DOUBLE: {
- double d;
-
- if (Tcl_IsShared(valuePtr)) {
- TclNewDoubleObj(objResultPtr, -(*((const double *)ptr)));
- NEXT_INST_F(1, 1, 1);
- }
- d = *((const double *)ptr);
- TclSetDoubleObj(valuePtr, -d);
+ switch (type1) {
+ case TCL_NUMBER_NAN:
+ /* -NaN => NaN */
NEXT_INST_F(1, 0, 0);
- }
- case TCL_NUMBER_LONG: {
- long l = *((const long *)ptr);
-
- if (l != LONG_MIN) {
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, -l);
- NEXT_INST_F(1, 1, 1);
- }
- TclSetLongObj(valuePtr, -l);
- NEXT_INST_F(1, 0, 0);
- }
- /* FALLTHROUGH */
- }
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE: {
- Tcl_WideInt w;
-
- if (type == TCL_NUMBER_LONG) {
- w = (Tcl_WideInt)(*((const long *)ptr));
- } else {
- w = *((const Tcl_WideInt *)ptr);
- }
- if (w != LLONG_MIN) {
+ case TCL_NUMBER_LONG:
+ l1 = *((const long *) ptr1);
+ if (l1 != LONG_MIN) {
if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(-w);
+ TclNewLongObj(objResultPtr, -l1);
NEXT_INST_F(1, 1, 1);
}
- Tcl_SetWideIntObj(valuePtr, -w);
+ TclSetLongObj(valuePtr, -l1);
NEXT_INST_F(1, 0, 0);
}
/* FALLTHROUGH */
}
-#endif
- case TCL_NUMBER_BIG: {
- mp_int big;
-
- switch (type) {
-#ifdef NO_WIDE_TYPE
- case TCL_NUMBER_LONG:
- TclBNInitBignumFromLong(&big, *(const long *) ptr);
- break;
-#else
- case TCL_NUMBER_WIDE:
- TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr);
- break;
-#endif
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
- }
- mp_neg(&big, &big);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&big);
- NEXT_INST_F(1, 1, 1);
- }
- Tcl_SetBignumObj(valuePtr, &big);
- NEXT_INST_F(1, 0, 0);
- }
- case TCL_NUMBER_NAN:
- /* -NaN => NaN */
+ objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
+ if (objResultPtr != NULL) {
+ NEXT_INST_F(1, 1, 1);
+ } else {
NEXT_INST_F(1, 0, 0);
}
- }
case INST_UPLUS:
- case INST_TRY_CVT_TO_NUMERIC: {
+ case INST_TRY_CVT_TO_NUMERIC:
/*
* Try to convert the topmost stack object to numeric object. This is
* done in order to support [expr]'s policy of interpreting operands
* if at all possible as numbers first, then strings.
*/
- ClientData ptr;
- int type;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
+ valuePtr = OBJ_AT_TOS;
- if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
+ if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
*/
- result = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
- } else {
- /* ... TryConvertToNumeric($NonNumeric) is acceptable */
- TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
- NEXT_INST_F(1, 0, 0);
+ goto gotError;
}
+
+ /* ... TryConvertToNumeric($NonNumeric) is acceptable */
+ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
}
-#ifndef ACCEPT_NAN
- if (type == TCL_NUMBER_NAN) {
- result = TCL_ERROR;
+ if (IsErroringNaNType(type1)) {
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
@@ -6492,12 +5326,11 @@ TclExecuteByteCode(
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(objResultPtr)));
DECACHE_STACK_INFO();
- TclExprFloatError(interp, *((const double *)ptr));
+ TclExprFloatError(interp, *((const double *) ptr1));
CACHE_STACK_INFO();
}
- goto checkForCatch;
+ goto gotError;
}
-#endif
/*
* Ensure that the numeric value has a string rep the same as the
@@ -6532,6 +5365,11 @@ TclExecuteByteCode(
NEXT_INST_F(1, 0, 0);
}
+ /*
+ * End of numeric operator instructions.
+ * -----------------------------------------------------------------
+ */
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -6552,21 +5390,25 @@ TclExecuteByteCode(
cleanup = 0;
goto processExceptionReturn;
- case INST_FOREACH_START4: {
+ {
+ ForeachInfo *infoPtr;
+ Var *iterVarPtr, *listVarPtr;
+ Tcl_Obj *oldValuePtr, *listPtr, **elements;
+ ForeachVarList *varListPtr;
+ int numLists, iterNum, listTmpIndex, listLen, numVars;
+ int varIndex, valIndex, continueLoop, j, iterTmpIndex;
+ long i;
+
+ case INST_FOREACH_START4:
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
- int opnd, iterTmpIndex;
- ForeachInfo *infoPtr;
- Var *iterVarPtr;
- Tcl_Obj *oldValuePtr;
-
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
- iterVarPtr = &(compiledLocals[iterTmpIndex]);
+ iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
@@ -6589,33 +5431,24 @@ TclExecuteByteCode(
#else
NEXT_INST_F(5, 0, 0);
#endif
- }
- case INST_FOREACH_STEP4: {
+ case INST_FOREACH_STEP4:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
- ForeachInfo *infoPtr;
- ForeachVarList *varListPtr;
- Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements;
- Var *iterVarPtr, *listVarPtr, *varPtr;
- int opnd, numLists, iterNum, listTmpIndex, listLen, numVars;
- int varIndex, valIndex, continueLoop, j;
- long i;
-
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
* Increment the temp holding the loop iteration number.
*/
- iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
+ iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
- iterNum = (valuePtr->internalRep.longValue + 1);
+ iterNum = valuePtr->internalRep.longValue + 1;
TclSetLongObj(valuePtr, iterNum);
/*
@@ -6629,19 +5462,17 @@ TclExecuteByteCode(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
- listVarPtr = &(compiledLocals[listTmpIndex]);
+ listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
- result = TclListObjLength(interp, listPtr, &listLen);
- if (result == TCL_OK) {
- if (listLen > (iterNum * numVars)) {
- continueLoop = 1;
- }
- listTmpIndex++;
- } else {
+ if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
+ }
+ if (listLen > iterNum * numVars) {
+ continueLoop = 1;
}
+ listTmpIndex++;
}
/*
@@ -6659,7 +5490,7 @@ TclExecuteByteCode(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
- listVarPtr = &(compiledLocals[listTmpIndex]);
+ listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
TclListObjGetElements(interp, listPtr, &listLen, &elements);
@@ -6672,7 +5503,7 @@ TclExecuteByteCode(
}
varIndex = varListPtr->varIndexes[j];
- varPtr = &(compiledLocals[varIndex]);
+ varPtr = LOCAL(varIndex);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6687,17 +5518,16 @@ TclExecuteByteCode(
}
} else {
DECACHE_STACK_INFO();
- value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
- NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
+ 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));
- result = TCL_ERROR;
TclDecrRefCount(listPtr);
- goto checkForCatch;
+ goto gotError;
}
+ CACHE_STACK_INFO();
}
valIndex++;
}
@@ -6751,14 +5581,10 @@ TclExecuteByteCode(
/*
* See the comments at INST_INVOKE_STK
*/
- {
- Tcl_Obj *newObjResultPtr;
-
- TclNewObj(newObjResultPtr);
- Tcl_IncrRefCount(newObjResultPtr);
- iPtr->objResultPtr = newObjResultPtr;
- }
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ iPtr->objResultPtr = objPtr;
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
@@ -6767,15 +5593,38 @@ TclExecuteByteCode(
NEXT_INST_F(1, 0, 1);
case INST_PUSH_RETURN_OPTIONS:
+ DECACHE_STACK_INFO();
objResultPtr = Tcl_GetReturnOptions(interp, result);
+ CACHE_STACK_INFO();
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
-/* TODO: normalize "valPtr" to "valuePtr" */
+ case INST_RETURN_CODE_BRANCH: {
+ int code;
+
+ if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) {
+ Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!");
+ }
+ if (code == TCL_OK) {
+ Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!");
+ }
+ if (code < TCL_ERROR || code > TCL_CONTINUE) {
+ code = TCL_CONTINUE + 1;
+ }
+ NEXT_INST_F(2*code -1, 1, 0);
+ }
+
+ /*
+ * -----------------------------------------------------------------
+ * Start of dictionary-related instructions.
+ */
+
{
- int opnd, opnd2, allocateDict;
- Tcl_Obj *dictPtr, *valPtr;
- Var *varPtr;
+ int opnd2, allocateDict, done, i, allocdict;
+ Tcl_Obj *dictPtr, *statePtr, *keyPtr;
+ Tcl_Obj *emptyPtr, **keyPtrPtr;
+ Tcl_DictSearch *searchPtr;
+ DictUpdateInfo *duiPtr;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -6789,29 +5638,29 @@ TclExecuteByteCode(
"%u => ERROR tracing dictionary path into \"%s\": ",
opnd, O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr);
- if ((result == TCL_OK) && objResultPtr) {
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
- }
- if (result != TCL_OK) {
- TRACE_WITH_OBJ((
- "%u => ERROR reading leaf dictionary key \"%s\": ",
- opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
- } else {
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
+ &objResultPtr) == TCL_OK) {
+ if (objResultPtr) {
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
"\" not known in dictionary", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
+ } else {
+ TRACE_WITH_OBJ((
+ "%u => ERROR reading leaf dictionary key \"%s\": ",
+ opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
}
- goto checkForCatch;
+ goto gotError;
case INST_DICT_SET:
case INST_DICT_UNSET:
@@ -6819,7 +5668,7 @@ TclExecuteByteCode(
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd2]);
+ varPtr = LOCAL(opnd2);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6850,25 +5699,24 @@ TclExecuteByteCode(
case INST_DICT_INCR_IMM:
cleanup = 1;
opnd = TclGetInt4AtPtr(pc+1);
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr);
+ result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
- if (valPtr == NULL) {
+ if (valuePtr == NULL) {
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
} else {
- Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd);
-
- Tcl_IncrRefCount(incrPtr);
- if (Tcl_IsShared(valPtr)) {
- valPtr = Tcl_DuplicateObj(valPtr);
- Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valPtr);
+ value2Ptr = Tcl_NewIntObj(opnd);
+ Tcl_IncrRefCount(value2Ptr);
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr);
}
- result = TclIncrObj(interp, valPtr, incrPtr);
+ result = TclIncrObj(interp, valuePtr, value2Ptr);
if (result == TCL_OK) {
Tcl_InvalidateStringRep(dictPtr);
}
- TclDecrRefCount(incrPtr);
+ TclDecrRefCount(value2Ptr);
}
break;
case INST_DICT_UNSET:
@@ -6892,11 +5740,10 @@ TclExecuteByteCode(
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
- Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
-
+ value2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr);
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -6911,8 +5758,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
@@ -6926,8 +5772,7 @@ TclExecuteByteCode(
case INST_DICT_APPEND:
case INST_DICT_LAPPEND:
opnd = TclGetUInt4AtPtr(pc+1);
-
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6949,29 +5794,40 @@ TclExecuteByteCode(
}
}
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr);
- if (result != TCL_OK) {
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
+ &valuePtr) != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ goto gotError;
}
/*
- * Note that a non-existent key results in a NULL valPtr, which is a
+ * Note that a non-existent key results in a NULL valuePtr, which is a
* case handled separately below. What we *can* say at this point is
* that the write-back will always succeed.
*/
switch (*pc) {
case INST_DICT_APPEND:
- if (valPtr == NULL) {
- valPtr = OBJ_AT_TOS;
+ if (valuePtr == NULL) {
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS);
+ } else if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS);
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
} else {
- if (Tcl_IsShared(valPtr)) {
- valPtr = Tcl_DuplicateObj(valPtr);
- }
- Tcl_AppendObjToObj(valPtr, OBJ_AT_TOS);
+ Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS);
+
+ /*
+ * Must invalidate the string representation of dictionary
+ * here because we have directly updated the internal
+ * representation; if we don't, callers could see the wrong
+ * string rep despite the internal version of the dictionary
+ * having the correct value. [Bug 3079830]
+ */
+
+ TclInvalidateStringRep(dictPtr);
}
break;
case INST_DICT_LAPPEND:
@@ -6979,41 +5835,51 @@ TclExecuteByteCode(
* More complex because list-append can fail.
*/
- if (valPtr == NULL) {
- valPtr = Tcl_NewListObj(1, &OBJ_AT_TOS);
- } else if (Tcl_IsShared(valPtr)) {
- valPtr = Tcl_DuplicateObj(valPtr);
- result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
- if (result != TCL_OK) {
- TclDecrRefCount(valPtr);
+ if (valuePtr == NULL) {
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS,
+ Tcl_NewListObj(1, &OBJ_AT_TOS));
+ break;
+ } else if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjAppendElement(interp, valuePtr,
+ OBJ_AT_TOS) != TCL_OK) {
+ TclDecrRefCount(valuePtr);
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
} else {
- result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
- if (result != TCL_OK) {
+ if (Tcl_ListObjAppendElement(interp, valuePtr,
+ OBJ_AT_TOS) != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ goto gotError;
}
+
+ /*
+ * Must invalidate the string representation of dictionary
+ * here because we have directly updated the internal
+ * representation; if we don't, callers could see the wrong
+ * string rep despite the internal version of the dictionary
+ * having the correct value. [Bug 3079830]
+ */
+
+ TclInvalidateStringRep(dictPtr);
}
break;
default:
Tcl_Panic("Should not happen!");
}
- Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valPtr);
-
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
- Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
-
+ value2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr);
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -7028,8 +5894,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
@@ -7039,36 +5904,27 @@ TclExecuteByteCode(
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
- }
-
- {
- int opnd, done;
- Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
- Var *varPtr;
- Tcl_DictSearch *searchPtr;
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
- searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
- result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
- &valuePtr, &done);
- if (result != TCL_OK) {
- ckfree((char *) searchPtr);
- goto checkForCatch;
+ searchPtr = ckalloc(sizeof(Tcl_DictSearch));
+ if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
+ &valuePtr, &done) != TCL_OK) {
+ ckfree(searchPtr);
+ goto gotError;
}
TclNewObj(statePtr);
statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr;
- varPtr = (compiledLocals + opnd);
+ statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
+ statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
- TclDecrRefCount(varPtr->value.objPtr);
- } else {
+ if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
Tcl_Panic("mis-issued dictFirst!");
}
+ TclDecrRefCount(varPtr->value.objPtr);
}
varPtr->value.objPtr = statePtr;
Tcl_IncrRefCount(statePtr);
@@ -7077,11 +5933,11 @@ TclExecuteByteCode(
case INST_DICT_NEXT:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
- statePtr = compiledLocals[opnd].value.objPtr;
+ statePtr = (*LOCAL(opnd)).value.objPtr;
if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
Tcl_Panic("mis-issued dictNext!");
}
- searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1;
+ searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:
if (done) {
@@ -7092,57 +5948,41 @@ TclExecuteByteCode(
PUSH_OBJECT(valuePtr);
PUSH_OBJECT(keyPtr);
}
- TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
- objResultPtr = constants[done];
- /* TODO: consider opt like INST_FOREACH_STEP4 */
- NEXT_INST_F(5, 0, 1);
- case INST_DICT_DONE:
- opnd = TclGetUInt4AtPtr(pc+1);
- TRACE(("%u => ", opnd));
- statePtr = compiledLocals[opnd].value.objPtr;
- if (statePtr == NULL) {
- Tcl_Panic("mis-issued dictDone!");
- }
-
- if (statePtr->typePtr == &dictIteratorType) {
- /*
- * First kill the search, and then release the reference to the
- * dictionary that we were holding.
- */
-
- searchPtr = (Tcl_DictSearch *)
- statePtr->internalRep.twoPtrValue.ptr1;
- Tcl_DictObjDone(searchPtr);
- ckfree((char *) searchPtr);
-
- dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2;
- TclDecrRefCount(dictPtr);
-
- /*
- * Set the internal variable to an empty object to signify that we
- * don't hold an iterator.
- */
+#ifndef TCL_COMPILE_DEBUG
+ /*
+ * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always
+ * followed by a conditional jump, so we can take advantage of this to
+ * do some peephole optimization (note that we're careful to not close
+ * out someone doing something else).
+ */
- TclDecrRefCount(statePtr);
- TclNewObj(emptyPtr);
- compiledLocals[opnd].value.objPtr = emptyPtr;
- Tcl_IncrRefCount(emptyPtr);
+ pc += 5;
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0);
+ default:
+ pc -= 5;
+ /* fall through to non-debug handling */
}
- NEXT_INST_F(5, 0, 0);
- }
+#endif
- {
- int opnd, opnd2, i, length, allocdict;
- Tcl_Obj **keyPtrPtr, *dictPtr;
- DictUpdateInfo *duiPtr;
- Var *varPtr;
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
+ objResultPtr = TCONST(done);
+ /* TODO: consider opt like INST_FOREACH_STEP4 */
+ NEXT_INST_F(5, 0, 1);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -7156,39 +5996,35 @@ TclExecuteByteCode(
TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (dictPtr == NULL) {
- goto dictUpdateStartFailed;
+ goto gotError;
}
}
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
- goto dictUpdateStartFailed;
+ goto gotError;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
- Tcl_Obj *valPtr;
-
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
- &valPtr) != TCL_OK) {
- goto dictUpdateStartFailed;
+ &valuePtr) != TCL_OK) {
+ goto gotError;
}
- varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
+ varPtr = LOCAL(duiPtr->varIndices[i]);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
- if (valPtr == NULL) {
+ if (valuePtr == NULL) {
TclObjUnsetVar2(interp,
localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
NULL, 0);
} else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
- valPtr, TCL_LEAVE_ERR_MSG,
+ valuePtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
- dictUpdateStartFailed:
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
CACHE_STACK_INFO();
}
@@ -7197,7 +6033,7 @@ TclExecuteByteCode(
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -7216,36 +6052,36 @@ TclExecuteByteCode(
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
allocdict = Tcl_IsShared(dictPtr);
if (allocdict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
+ if (length > 0) {
+ TclInvalidateStringRep(dictPtr);
+ }
for (i=0 ; i<length ; i++) {
- Tcl_Obj *valPtr;
- Var *var2Ptr;
+ Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);
- var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);
while (TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;
}
if (TclIsVarDirectReadable(var2Ptr)) {
- valPtr = var2Ptr->value.objPtr;
+ valuePtr = var2Ptr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- valPtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
+ valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
duiPtr->varIndices[i]);
CACHE_STACK_INFO();
}
- if (valPtr == NULL) {
+ if (valuePtr == NULL) {
Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
- } else if (dictPtr == valPtr) {
+ } else if (dictPtr == valuePtr) {
Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
- Tcl_DuplicateObj(valPtr));
+ Tcl_DuplicateObj(valuePtr));
} else {
- Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
+ Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr);
}
}
if (TclIsVarDirectWritable(varPtr)) {
@@ -7261,45 +6097,20 @@ TclExecuteByteCode(
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
NEXT_INST_F(9, 1, 0);
}
- default:
- Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
- } /* end of switch on opCode */
-
/*
- * Division by zero in an expression. Control only reaches this point by
- * "goto divideByZero".
+ * End of dictionary-related instructions.
+ * -----------------------------------------------------------------
*/
- divideByZero:
- DECACHE_STACK_INFO();
- Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
- Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
- CACHE_STACK_INFO();
-
- result = TCL_ERROR;
- goto checkForCatch;
-
- /*
- * Exponentiation of zero by negative number in an expression. Control
- * only reaches this point by "goto exponOfZero".
- */
-
- exponOfZero:
- DECACHE_STACK_INFO();
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "exponentiation of zero by negative power", -1));
- Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
- "exponentiation of zero by negative power", NULL);
- CACHE_STACK_INFO();
- result = TCL_ERROR;
- goto checkForCatch;
+ default:
+ Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
+ } /* end of switch on opCode */
/*
* Block for variables needed to process exception returns.
@@ -7311,12 +6122,7 @@ TclExecuteByteCode(
* range enclosing the pc. Used by various
* instructions and processCatch to process
* break, continue, and errors. */
- Tcl_Obj *valuePtr;
const char *bytes;
- int length;
-#if TCL_COMPILE_DEBUG
- int opnd;
-#endif
/*
* An external evaluation (INST_INVOKE or INST_EVAL) returned
@@ -7369,33 +6175,65 @@ TclExecuteByteCode(
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
- } else {
- if (rangePtr->continueOffset == -1) {
- TRACE_APPEND((
- "%s, loop w/o continue, checking for catch\n",
- StringForResultCode(result)));
- goto checkForCatch;
- }
- result = TCL_OK;
- pc = (codePtr->codeStart + rangePtr->continueOffset);
- TRACE_APPEND(("%s, range at %d, new pc %d\n",
- StringForResultCode(result),
- rangePtr->codeOffset, rangePtr->continueOffset));
- NEXT_INST_F(0, 0, 0);
}
+ if (rangePtr->continueOffset == -1) {
+ TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
+ StringForResultCode(result)));
+ goto checkForCatch;
+ }
+ result = TCL_OK;
+ pc = (codePtr->codeStart + rangePtr->continueOffset);
+ TRACE_APPEND(("%s, range at %d, new pc %d\n",
+ StringForResultCode(result),
+ rangePtr->codeOffset, rangePtr->continueOffset));
+ NEXT_INST_F(0, 0, 0);
+ }
#if TCL_COMPILE_DEBUG
- } else if (traceInstructions) {
+ if (traceInstructions) {
+ objPtr = Tcl_GetObjResult(interp);
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
- Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
result, O2S(objPtr)));
} else {
- Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= \"%s\"\n",
StringForResultCode(result), O2S(objPtr)));
}
-#endif
}
+#endif
+ goto checkForCatch;
+
+ /*
+ * Division by zero in an expression. Control only reaches this point
+ * by "goto divideByZero".
+ */
+
+ divideByZero:
+ DECACHE_STACK_INFO();
+ Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+
+ /*
+ * Exponentiation of zero by negative number in an expression. Control
+ * only reaches this point by "goto exponOfZero".
+ */
+
+ exponOfZero:
+ DECACHE_STACK_INFO();
+ Tcl_SetResult(interp, "exponentiation of zero by negative power",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "exponentiation of zero by negative power", NULL);
+ CACHE_STACK_INFO();
+
+ /*
+ * Almost all error paths feed through here rather than assigning to
+ * result themselves (for a small but consistent saving).
+ */
+
+ gotError:
+ result = TCL_ERROR;
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
@@ -7405,14 +6243,18 @@ TclExecuteByteCode(
* and return the "exception" code.
*/
- checkForCatch:
+ checkForCatch:
+ if (iPtr->execEnvPtr->rewind) {
+ goto abnormalReturn;
+ }
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- bytes = GetSrcInfoForPc(pc, codePtr, &length);
- if (bytes != NULL) {
- DECACHE_STACK_INFO();
- Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
- CACHE_STACK_INFO();
- }
+ const unsigned char *pcBeg;
+
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
+ DECACHE_STACK_INFO();
+ TclLogCommandInfo(interp, codePtr->source, bytes,
+ bytes ? length : 0, pcBeg, tosPtr);
+ CACHE_STACK_INFO();
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
@@ -7421,13 +6263,31 @@ TclExecuteByteCode(
* INST_BEGIN_CATCH.
*/
- while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
- (*catchTop <=
- (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
+ while (auxObjList) {
+ if ((catchTop != initCatchTop) &&
+ (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) {
+ break;
+ }
+ POP_TAUX_OBJ();
+ }
+
+ /*
+ * We must not catch if the script in progress has been canceled with
+ * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we
+ * either hit another interpreter (presumably where the script in
+ * progress has not been canceled) or we get to the top-level. We do
+ * NOT modify the interpreter result here because we know it will
+ * already be set prior to vectoring down to this point in the code.
+ */
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
+ if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) {
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... cancel with unwind, returning %s\n",
+ StringForResultCode(result));
+ }
+#endif
+ goto abnormalReturn;
}
/*
@@ -7459,7 +6319,7 @@ TclExecuteByteCode(
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
- * breakingcompat with previous .tbc compiled scripts.
+ * breaking compat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
@@ -7507,39 +6367,1406 @@ TclExecuteByteCode(
abnormalReturn:
TCL_DTRACE_INST_LAST();
- while (tosPtr > initTosPtr) {
- Tcl_Obj *objPtr = POP_OBJECT();
-
- Tcl_DecrRefCount(objPtr);
- }
/*
- * Clear all expansions.
+ * Clear all expansions and same-level NR calls.
+ *
+ * Note that expansion markers have a NULL type; avoid removing other
+ * markers.
*/
- while (expandNestList) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
-
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
+ while (auxObjList) {
+ POP_TAUX_OBJ();
}
+ while (tosPtr > initTosPtr) {
+ objPtr = POP_OBJECT();
+ Tcl_DecrRefCount(objPtr);
+ }
+
if (tosPtr < initTosPtr) {
fprintf(stderr,
- "\nTclExecuteByteCode: abnormal return at pc %u: "
+ "\nTclNRExecuteByteCode: abnormal return at pc %u: "
"stack top %d < entry stack top %d\n",
(unsigned)(pc - codePtr->codeStart),
(unsigned) CURR_DEPTH, (unsigned) 0);
- Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
+ CLANG_ASSERT(bcFramePtr);
}
- /*
- * Restore the stack to the state it had previous to this bytecode.
- */
+ iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+ if (--codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+ TclStackFree(interp, TD); /* free my stack */
- TclStackFree(interp, initCatchTop+1);
return result;
+}
+
+#undef codePtr
#undef iPtr
+#undef bcFramePtr
+#undef initCatchTop
+#undef initTosPtr
+#undef auxObjList
+#undef catchTop
+#undef TCONST
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExecuteExtendedBinaryMathOp, ExecuteExtendedUnaryMathOp --
+ *
+ * These functions do advanced math for binary and unary operators
+ * respectively, so that the main TEBC code does not bear the cost of
+ * them.
+ *
+ * Results:
+ * A Tcl_Obj* result, or a NULL (in which case valuePtr is updated to
+ * hold the result value), or one of the special flag values
+ * GENERAL_ARITHMETIC_ERROR, EXPONENT_OF_ZERO or DIVIDED_BY_ZERO. The
+ * latter two signify a zero value raised to a negative power or a value
+ * divided by zero, respectively. With GENERAL_ARITHMETIC_ERROR, all
+ * error information will have already been reported in the interpreter
+ * result.
+ *
+ * Side effects:
+ * May update the Tcl_Obj indicated valuePtr if it is unshared. Will
+ * return a NULL when that happens.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ExecuteExtendedBinaryMathOp(
+ Tcl_Interp *interp, /* Where to report errors. */
+ int opcode, /* What operation to perform. */
+ Tcl_Obj **constants, /* The execution environment's constants. */
+ Tcl_Obj *valuePtr, /* The first operand on the stack. */
+ Tcl_Obj *value2Ptr) /* The second operand on the stack. */
+{
+#define LONG_RESULT(l) \
+ if (Tcl_IsShared(valuePtr)) { \
+ TclNewLongObj(objResultPtr, l); \
+ return objResultPtr; \
+ } else { \
+ Tcl_SetLongObj(valuePtr, l); \
+ return NULL; \
+ }
+#define WIDE_RESULT(w) \
+ if (Tcl_IsShared(valuePtr)) { \
+ return Tcl_NewWideIntObj(w); \
+ } else { \
+ Tcl_SetWideIntObj(valuePtr, w); \
+ return NULL; \
+ }
+#define BIG_RESULT(b) \
+ if (Tcl_IsShared(valuePtr)) { \
+ return Tcl_NewBignumObj(b); \
+ } else { \
+ Tcl_SetBignumObj(valuePtr, b); \
+ return NULL; \
+ }
+#define DOUBLE_RESULT(d) \
+ if (Tcl_IsShared(valuePtr)) { \
+ TclNewDoubleObj(objResultPtr, (d)); \
+ return objResultPtr; \
+ } else { \
+ Tcl_SetDoubleObj(valuePtr, (d)); \
+ return NULL; \
+ }
+
+ int type1, type2;
+ ClientData ptr1, ptr2;
+ double d1, d2, dResult;
+ long l1, l2, lResult;
+ Tcl_WideInt w1, w2, wResult;
+ mp_int big1, big2, bigResult, bigRemainder;
+ Tcl_Obj *objResultPtr;
+ int invalid, numPos, zero;
+ long shift;
+
+ (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
+ (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
+
+ switch (opcode) {
+ case INST_MOD:
+ /* TODO: Attempts to re-use unshared operands on stack */
+
+ l2 = 0; /* silence gcc warning */
+ if (type2 == TCL_NUMBER_LONG) {
+ l2 = *((const long *)ptr2);
+ if (l2 == 0) {
+ return DIVIDED_BY_ZERO;
+ }
+ if ((l2 == 1) || (l2 == -1)) {
+ /*
+ * Div. by |1| always yields remainder of 0.
+ */
+
+ return constants[0];
+ }
+ }
+#ifndef NO_WIDE_TYPE
+ if (type1 == TCL_NUMBER_WIDE) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ if (type2 != TCL_NUMBER_BIG) {
+ Tcl_WideInt wQuotient, wRemainder;
+ Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
+ wQuotient = w1 / w2;
+
+ /*
+ * Force Tcl's integer division rules.
+ * TODO: examine for logic simplification
+ */
+
+ if (((wQuotient < (Tcl_WideInt) 0)
+ || ((wQuotient == (Tcl_WideInt) 0)
+ && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
+ || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
+ && (wQuotient * w2 != w1)) {
+ wQuotient -= (Tcl_WideInt) 1;
+ }
+ wRemainder = w1 - w2*wQuotient;
+ WIDE_RESULT(wRemainder);
+ }
+
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+
+ /* TODO: internals intrusion */
+ if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) {
+ /*
+ * Arguments are opposite sign; remainder is sum.
+ */
+
+ TclBNInitBignumFromWideInt(&big1, w1);
+ mp_add(&big2, &big1, &big2);
+ mp_clear(&big1);
+ BIG_RESULT(&big2);
+ }
+
+ /*
+ * Arguments are same sign; remainder is first operand.
+ */
+
+ mp_clear(&big2);
+ return NULL;
+ }
+#endif
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ mp_init(&bigResult);
+ mp_init(&bigRemainder);
+ mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) {
+ /*
+ * Convert to Tcl's integer division rules.
+ */
+
+ mp_sub_d(&bigResult, 1, &bigResult);
+ mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ mp_copy(&bigRemainder, &bigResult);
+ mp_clear(&bigRemainder);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ BIG_RESULT(&bigResult);
+
+ case INST_LSHIFT:
+ case INST_RSHIFT: {
+ /*
+ * Reject negative shift argument.
+ */
+
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ invalid = (*((const long *)ptr2) < 0L);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ invalid = (mp_cmp_d(&big2, 0) == MP_LT);
+ mp_clear(&big2);
+ break;
+ default:
+ /* Unused, here to silence compiler warning */
+ invalid = 0;
+ }
+ if (invalid) {
+ Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
+ return GENERAL_ARITHMETIC_ERROR;
+ }
+
+ /*
+ * Zero shifted any number of bits is still zero.
+ */
+
+ if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
+ return constants[0];
+ }
+
+ if (opcode == INST_LSHIFT) {
+ /*
+ * Large left shifts create integer overflow.
+ *
+ * BEWARE! Can't use Tcl_GetIntFromObj() here because that
+ * converts values in the (unsigned) range to their signed int
+ * counterparts, leading to incorrect results.
+ */
+
+ if ((type2 != TCL_NUMBER_LONG)
+ || (*((const long *)ptr2) > (long) INT_MAX)) {
+ /*
+ * Technically, we could hold the value (1 << (INT_MAX+1)) in
+ * an mp_int, but since we're using mp_mul_2d() to do the
+ * work, and it takes only an int argument, that's a good
+ * place to draw the line.
+ */
+
+ Tcl_SetResult(interp, "integer value too large to represent",
+ TCL_STATIC);
+ return GENERAL_ARITHMETIC_ERROR;
+ }
+ shift = (int)(*((const long *)ptr2));
+
+ /*
+ * Handle shifts within the native wide range.
+ */
+
+ if ((type1 != TCL_NUMBER_BIG)
+ && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ if (!((w1>0 ? w1 : ~w1)
+ & -(((Tcl_WideInt)1)
+ << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
+ WIDE_RESULT(w1 << shift);
+ }
+ }
+ } else {
+ /*
+ * Quickly force large right shifts to 0 or -1.
+ */
+
+ if ((type2 != TCL_NUMBER_LONG)
+ || (*(const long *)ptr2 > INT_MAX)) {
+ /*
+ * Again, technically, the value to be shifted could be an
+ * mp_int so huge that a right shift by (INT_MAX+1) bits could
+ * not take us to the result of 0 or -1, but since we're using
+ * mp_div_2d to do the work, and it takes only an int
+ * argument, we draw the line there.
+ */
+
+ switch (type1) {
+ case TCL_NUMBER_LONG:
+ zero = (*(const long *)ptr1 > 0L);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+ zero = (mp_cmp_d(&big1, 0) == MP_GT);
+ mp_clear(&big1);
+ break;
+ default:
+ /* Unused, here to silence compiler warning. */
+ zero = 0;
+ }
+ if (zero) {
+ return constants[0];
+ }
+ LONG_RESULT(-1);
+ }
+ shift = (int)(*(const long *)ptr2);
+
+#ifndef NO_WIDE_TYPE
+ /*
+ * Handle shifts within the native wide range.
+ */
+
+ if (type1 == TCL_NUMBER_WIDE) {
+ w1 = *(const Tcl_WideInt *)ptr1;
+ if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
+ if (w1 >= (Tcl_WideInt)0) {
+ return constants[0];
+ }
+ LONG_RESULT(-1);
+ }
+ WIDE_RESULT(w1 >> shift);
+ }
+#endif
+ }
+
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+
+ mp_init(&bigResult);
+ if (opcode == INST_LSHIFT) {
+ mp_mul_2d(&big1, shift, &bigResult);
+ } else {
+ mp_init(&bigRemainder);
+ mp_div_2d(&big1, shift, &bigResult, &bigRemainder);
+ if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
+ /*
+ * Convert to Tcl's integer division rules.
+ */
+
+ mp_sub_d(&bigResult, 1, &bigResult);
+ }
+ mp_clear(&bigRemainder);
+ }
+ mp_clear(&big1);
+ BIG_RESULT(&bigResult);
+ }
+
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
+ mp_int *First, *Second;
+
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+
+ /*
+ * Count how many positive arguments we have. If only one of the
+ * arguments is negative, store it in 'Second'.
+ */
+
+ if (mp_cmp_d(&big1, 0) != MP_LT) {
+ numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT);
+ First = &big1;
+ Second = &big2;
+ } else {
+ First = &big2;
+ Second = &big1;
+ numPos = (mp_cmp_d(First, 0) != MP_LT);
+ }
+ mp_init(&bigResult);
+
+ switch (opcode) {
+ case INST_BITAND:
+ switch (numPos) {
+ case 2:
+ /*
+ * Both arguments positive, base case.
+ */
+
+ mp_and(First, Second, &bigResult);
+ break;
+ case 1:
+ /*
+ * First is positive; second negative:
+ * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1))
+ */
+
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_xor(First, Second, &bigResult);
+ mp_and(First, &bigResult, &bigResult);
+ break;
+ case 0:
+ /*
+ * Both arguments negative:
+ * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1
+ */
+
+ mp_neg(First, First);
+ mp_sub_d(First, 1, First);
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_or(First, Second, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ }
+ break;
+
+ case INST_BITOR:
+ switch (numPos) {
+ case 2:
+ /*
+ * Both arguments positive, base case.
+ */
+
+ mp_or(First, Second, &bigResult);
+ break;
+ case 1:
+ /*
+ * First is positive; second negative:
+ * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1
+ */
+
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_xor(First, Second, &bigResult);
+ mp_and(Second, &bigResult, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ case 0:
+ /*
+ * Both arguments negative:
+ * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1
+ */
+
+ mp_neg(First, First);
+ mp_sub_d(First, 1, First);
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_and(First, Second, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ }
+ break;
+
+ case INST_BITXOR:
+ switch (numPos) {
+ case 2:
+ /*
+ * Both arguments positive, base case.
+ */
+
+ mp_xor(First, Second, &bigResult);
+ break;
+ case 1:
+ /*
+ * First is positive; second negative:
+ * P^N = ~(P^~N) = -(P^(-N-1))-1
+ */
+
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_xor(First, Second, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ case 0:
+ /*
+ * Both arguments negative:
+ * a ^ b = (~a ^ ~b) = (-a-1^-b-1)
+ */
+
+ mp_neg(First, First);
+ mp_sub_d(First, 1, First);
+ mp_neg(Second, Second);
+ mp_sub_d(Second, 1, Second);
+ mp_xor(First, Second, &bigResult);
+ break;
+ }
+ break;
+ }
+
+ mp_clear(&big1);
+ mp_clear(&big2);
+ BIG_RESULT(&bigResult);
+ }
+
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+
+ switch (opcode) {
+ case INST_BITAND:
+ wResult = w1 & w2;
+ break;
+ case INST_BITOR:
+ wResult = w1 | w2;
+ break;
+ case INST_BITXOR:
+ wResult = w1 ^ w2;
+ break;
+ default:
+ /* Unused, here to silence compiler warning. */
+ wResult = 0;
+ }
+ WIDE_RESULT(wResult);
+ }
+#endif
+ l1 = *((const long *)ptr1);
+ l2 = *((const long *)ptr2);
+
+ switch (opcode) {
+ case INST_BITAND:
+ lResult = l1 & l2;
+ break;
+ case INST_BITOR:
+ lResult = l1 | l2;
+ break;
+ case INST_BITXOR:
+ lResult = l1 ^ l2;
+ break;
+ default:
+ /* Unused, here to silence compiler warning. */
+ lResult = 0;
+ }
+ LONG_RESULT(lResult);
+
+ case INST_EXPON: {
+ int oddExponent = 0, negativeExponent = 0;
+ unsigned short base;
+
+ if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
+ Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
+ Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
+
+ if (d1==0.0 && d2<0.0) {
+ return EXPONENT_OF_ZERO;
+ }
+ dResult = pow(d1, d2);
+ goto doubleResult;
+ }
+ l1 = l2 = 0;
+ if (type2 == TCL_NUMBER_LONG) {
+ l2 = *((const long *) ptr2);
+ if (l2 == 0) {
+ /*
+ * Anything to the zero power is 1.
+ */
+
+ return constants[1];
+ } else if (l2 == 1) {
+ /*
+ * Anything to the first power is itself
+ */
+
+ return NULL;
+ }
+ }
+
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ negativeExponent = (l2 < 0);
+ oddExponent = (int) (l2 & 1);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w2 = *((const Tcl_WideInt *)ptr2);
+ negativeExponent = (w2 < 0);
+ oddExponent = (int) (w2 & (Tcl_WideInt)1);
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
+ mp_mod_2d(&big2, 1, &big2);
+ oddExponent = !mp_iszero(&big2);
+ mp_clear(&big2);
+ break;
+ }
+
+ if (type1 == TCL_NUMBER_LONG) {
+ l1 = *((const long *)ptr1);
+ }
+ if (negativeExponent) {
+ if (type1 == TCL_NUMBER_LONG) {
+ switch (l1) {
+ case 0:
+ /*
+ * Zero to a negative power is div by zero error.
+ */
+
+ return EXPONENT_OF_ZERO;
+ case -1:
+ if (oddExponent) {
+ LONG_RESULT(-1);
+ }
+ /* fallthrough */
+ case 1:
+ /*
+ * 1 to any power is 1.
+ */
+
+ return constants[1];
+ }
+ }
+
+ /*
+ * Integers with magnitude greater than 1 raise to a negative
+ * power yield the answer zero (see TIP 123).
+ */
+
+ return constants[0];
+ }
+
+ if (type1 == TCL_NUMBER_LONG) {
+ switch (l1) {
+ case 0:
+ /*
+ * Zero to a positive power is zero.
+ */
+
+ return constants[0];
+ case 1:
+ /*
+ * 1 to any power is 1.
+ */
+
+ return constants[1];
+ case -1:
+ if (!oddExponent) {
+ return constants[1];
+ }
+ LONG_RESULT(-1);
+ }
+ }
+
+ /*
+ * We refuse to accept exponent arguments that exceed one mp_digit
+ * which means the max exponent value is 2**28-1 = 0x0fffffff =
+ * 268435455, which fits into a signed 32 bit int which is within the
+ * range of the long int type. This means any numeric Tcl_Obj value
+ * not using TCL_NUMBER_LONG type must hold a value larger than we
+ * accept.
+ */
+
+ if (type2 != TCL_NUMBER_LONG) {
+ Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ return GENERAL_ARITHMETIC_ERROR;
+ }
+
+ if (type1 == TCL_NUMBER_LONG) {
+ if (l1 == 2) {
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
+
+ if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
+ LONG_RESULT(1L << l2);
+ }
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(((Tcl_WideInt) 1) << l2);
+ }
+#endif
+ goto overflowExpon;
+ }
+ if (l1 == -2) {
+ int signum = oddExponent ? -1 : 1;
+
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
+
+ if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
+ LONG_RESULT(signum * (1L << l2));
+ }
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
+ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
+ }
+#endif
+ goto overflowExpon;
+ }
+#if (LONG_MAX == 0x7fffffff)
+ if (l2 - 2 < (long)MaxBase32Size
+ && l1 <= MaxBase32[l2 - 2]
+ && l1 >= -MaxBase32[l2 - 2]) {
+ /*
+ * Small powers of 32-bit integers.
+ */
+
+ lResult = l1 * l1; /* b**2 */
+ switch (l2) {
+ case 2:
+ break;
+ case 3:
+ lResult *= l1; /* b**3 */
+ break;
+ case 4:
+ lResult *= lResult; /* b**4 */
+ break;
+ case 5:
+ lResult *= lResult; /* b**4 */
+ lResult *= l1; /* b**5 */
+ break;
+ case 6:
+ lResult *= l1; /* b**3 */
+ lResult *= lResult; /* b**6 */
+ break;
+ case 7:
+ lResult *= l1; /* b**3 */
+ lResult *= lResult; /* b**6 */
+ lResult *= l1; /* b**7 */
+ break;
+ case 8:
+ lResult *= lResult; /* b**4 */
+ lResult *= lResult; /* b**8 */
+ break;
+ }
+ LONG_RESULT(lResult);
+ }
+
+ if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize
+ && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
+ base = Exp32Index[l1 - 3]
+ + (unsigned short) (l2 - 2 - MaxBase32Size);
+ if (base < Exp32Index[l1 - 2]) {
+ /*
+ * 32-bit number raised to intermediate power, done by
+ * table lookup.
+ */
+
+ LONG_RESULT(Exp32Value[base]);
+ }
+ }
+ if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
+ && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
+ base = Exp32Index[-l1 - 3]
+ + (unsigned short) (l2 - 2 - MaxBase32Size);
+ if (base < Exp32Index[-l1 - 2]) {
+ /*
+ * 32-bit number raised to intermediate power, done by
+ * table lookup.
+ */
+
+ lResult = (oddExponent) ?
+ -Exp32Value[base] : Exp32Value[base];
+ LONG_RESULT(lResult);
+ }
+ }
+#endif
+ }
+#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
+ if (type1 == TCL_NUMBER_LONG) {
+ w1 = l1;
+#ifndef NO_WIDE_TYPE
+ } else if (type1 == TCL_NUMBER_WIDE) {
+ w1 = *((const Tcl_WideInt *) ptr1);
+#endif
+ } else {
+ goto overflowExpon;
+ }
+ if (l2 - 2 < (long)MaxBase64Size
+ && w1 <= MaxBase64[l2 - 2]
+ && w1 >= -MaxBase64[l2 - 2]) {
+ /*
+ * Small powers of integers whose result is wide.
+ */
+
+ wResult = w1 * w1; /* b**2 */
+ switch (l2) {
+ case 2:
+ break;
+ case 3:
+ wResult *= l1; /* b**3 */
+ break;
+ case 4:
+ wResult *= wResult; /* b**4 */
+ break;
+ case 5:
+ wResult *= wResult; /* b**4 */
+ wResult *= w1; /* b**5 */
+ break;
+ case 6:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ break;
+ case 7:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ wResult *= w1; /* b**7 */
+ break;
+ case 8:
+ wResult *= wResult; /* b**4 */
+ wResult *= wResult; /* b**8 */
+ break;
+ case 9:
+ wResult *= wResult; /* b**4 */
+ wResult *= wResult; /* b**8 */
+ wResult *= w1; /* b**9 */
+ break;
+ case 10:
+ wResult *= wResult; /* b**4 */
+ wResult *= w1; /* b**5 */
+ wResult *= wResult; /* b**10 */
+ break;
+ case 11:
+ wResult *= wResult; /* b**4 */
+ wResult *= w1; /* b**5 */
+ wResult *= wResult; /* b**10 */
+ wResult *= w1; /* b**11 */
+ break;
+ case 12:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ wResult *= wResult; /* b**12 */
+ break;
+ case 13:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ wResult *= wResult; /* b**12 */
+ wResult *= w1; /* b**13 */
+ break;
+ case 14:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ wResult *= w1; /* b**7 */
+ wResult *= wResult; /* b**14 */
+ break;
+ case 15:
+ wResult *= w1; /* b**3 */
+ wResult *= wResult; /* b**6 */
+ wResult *= w1; /* b**7 */
+ wResult *= wResult; /* b**14 */
+ wResult *= w1; /* b**15 */
+ break;
+ case 16:
+ wResult *= wResult; /* b**4 */
+ wResult *= wResult; /* b**8 */
+ wResult *= wResult; /* b**16 */
+ break;
+ }
+ WIDE_RESULT(wResult);
+ }
+
+ /*
+ * Handle cases of powers > 16 that still fit in a 64-bit word by
+ * doing table lookup.
+ */
+
+ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
+ && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ base = Exp64Index[w1 - 3]
+ + (unsigned short) (l2 - 2 - MaxBase64Size);
+ if (base < Exp64Index[w1 - 2]) {
+ /*
+ * 64-bit number raised to intermediate power, done by
+ * table lookup.
+ */
+
+ WIDE_RESULT(Exp64Value[base]);
+ }
+ }
+
+ if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
+ && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ base = Exp64Index[-w1 - 3]
+ + (unsigned short) (l2 - 2 - MaxBase64Size);
+ if (base < Exp64Index[-w1 - 2]) {
+ /*
+ * 64-bit number raised to intermediate power, done by
+ * table lookup.
+ */
+
+ wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
+ WIDE_RESULT(wResult);
+ }
+ }
+#endif
+
+ overflowExpon:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ if (big2.used > 1) {
+ mp_clear(&big2);
+ Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ return GENERAL_ARITHMETIC_ERROR;
+ }
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+ mp_init(&bigResult);
+ mp_expt_d(&big1, big2.dp[0], &bigResult);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ BIG_RESULT(&bigResult);
+ }
+
+ case INST_ADD:
+ case INST_SUB:
+ case INST_MULT:
+ case INST_DIV:
+ if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
+ /*
+ * At least one of the values is floating-point, so perform
+ * floating point calculations.
+ */
+
+ Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
+ Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
+
+ switch (opcode) {
+ case INST_ADD:
+ dResult = d1 + d2;
+ break;
+ case INST_SUB:
+ dResult = d1 - d2;
+ break;
+ case INST_MULT:
+ dResult = d1 * d2;
+ break;
+ case INST_DIV:
+#ifndef IEEE_FLOATING_POINT
+ if (d2 == 0.0) {
+ return DIVIDED_BY_ZERO;
+ }
+#endif
+ /*
+ * We presume that we are running with zero-divide unmasked if
+ * we're on an IEEE box. Otherwise, this statement might cause
+ * demons to fly out our noses.
+ */
+
+ dResult = d1 / d2;
+ break;
+ default:
+ /* Unused, here to silence compiler warning. */
+ dResult = 0;
+ }
+
+ doubleResult:
+#ifndef ACCEPT_NAN
+ /*
+ * Check now for IEEE floating-point error.
+ */
+
+ if (TclIsNaN(dResult)) {
+ TclExprFloatError(interp, dResult);
+ return GENERAL_ARITHMETIC_ERROR;
+ }
+#endif
+ DOUBLE_RESULT(dResult);
+ }
+ if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+
+ switch (opcode) {
+ case INST_ADD:
+ wResult = w1 + w2;
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
+ {
+ /*
+ * Check for overflow.
+ */
+
+ if (Overflowing(w1, w2, wResult)) {
+ goto overflowBasic;
+ }
+ }
+ break;
+
+ case INST_SUB:
+ wResult = w1 - w2;
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
+ {
+ /*
+ * Must check for overflow. The macro tests for overflows
+ * in sums by looking at the sign bits. As we have a
+ * subtraction here, we are adding -w2. As -w2 could in
+ * turn overflow, we test with ~w2 instead: it has the
+ * opposite sign bit to w2 so it does the job. Note that
+ * the only "bad" case (w2==0) is irrelevant for this
+ * macro, as in that case w1 and wResult have the same
+ * sign and there is no overflow anyway.
+ */
+
+ if (Overflowing(w1, ~w2, wResult)) {
+ goto overflowBasic;
+ }
+ }
+ break;
+
+ case INST_MULT:
+ if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG)
+ || (sizeof(Tcl_WideInt) < 2*sizeof(long))) {
+ goto overflowBasic;
+ }
+ wResult = w1 * w2;
+ break;
+
+ case INST_DIV:
+ if (w2 == 0) {
+ return DIVIDED_BY_ZERO;
+ }
+
+ /*
+ * Need a bignum to represent (LLONG_MIN / -1)
+ */
+
+ if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ goto overflowBasic;
+ }
+ wResult = w1 / w2;
+
+ /*
+ * Force Tcl's integer division rules.
+ * TODO: examine for logic simplification
+ */
+
+ if (((wResult < 0) || ((wResult == 0) &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ (wResult*w2 != w1)) {
+ wResult -= 1;
+ }
+ break;
+
+ default:
+ /*
+ * Unused, here to silence compiler warning.
+ */
+
+ wResult = 0;
+ }
+
+ WIDE_RESULT(wResult);
+ }
+
+ overflowBasic:
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ mp_init(&bigResult);
+ switch (opcode) {
+ case INST_ADD:
+ mp_add(&big1, &big2, &bigResult);
+ break;
+ case INST_SUB:
+ mp_sub(&big1, &big2, &bigResult);
+ break;
+ case INST_MULT:
+ mp_mul(&big1, &big2, &bigResult);
+ break;
+ case INST_DIV:
+ if (mp_iszero(&big2)) {
+ mp_clear(&big1);
+ mp_clear(&big2);
+ mp_clear(&bigResult);
+ return DIVIDED_BY_ZERO;
+ }
+ mp_init(&bigRemainder);
+ mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ /* TODO: internals intrusion */
+ if (!mp_iszero(&bigRemainder)
+ && (bigRemainder.sign != big2.sign)) {
+ /*
+ * Convert to Tcl's integer division rules.
+ */
+
+ mp_sub_d(&bigResult, 1, &bigResult);
+ mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ mp_clear(&bigRemainder);
+ break;
+ }
+ mp_clear(&big1);
+ mp_clear(&big2);
+ BIG_RESULT(&bigResult);
+ }
+
+ Tcl_Panic("unexpected opcode");
+ return NULL;
+}
+
+static Tcl_Obj *
+ExecuteExtendedUnaryMathOp(
+ int opcode, /* What operation to perform. */
+ Tcl_Obj *valuePtr) /* The operand on the stack. */
+{
+ ClientData ptr;
+ int type;
+ Tcl_WideInt w;
+ mp_int big;
+ Tcl_Obj *objResultPtr;
+
+ (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
+
+ switch (opcode) {
+ case INST_BITNOT:
+#ifndef NO_WIDE_TYPE
+ if (type == TCL_NUMBER_WIDE) {
+ w = *((const Tcl_WideInt *) ptr);
+ WIDE_RESULT(~w);
+ }
+#endif
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
+ /* ~a = - a - 1 */
+ mp_neg(&big, &big);
+ mp_sub_d(&big, 1, &big);
+ BIG_RESULT(&big);
+ case INST_UMINUS:
+ switch (type) {
+ case TCL_NUMBER_DOUBLE:
+ DOUBLE_RESULT(-(*((const double *) ptr)));
+ case TCL_NUMBER_LONG:
+ w = (Tcl_WideInt) (*((const long *) ptr));
+ if (w != LLONG_MIN) {
+ WIDE_RESULT(-w);
+ }
+ TclBNInitBignumFromLong(&big, *(const long *) ptr);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w = *((const Tcl_WideInt *) ptr);
+ if (w != LLONG_MIN) {
+ WIDE_RESULT(-w);
+ }
+ TclBNInitBignumFromWideInt(&big, w);
+ break;
+#endif
+ default:
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
+ }
+ mp_neg(&big, &big);
+ BIG_RESULT(&big);
+ }
+
+ Tcl_Panic("unexpected opcode");
+ return NULL;
+}
+#undef LONG_RESULT
+#undef WIDE_RESULT
+#undef BIG_RESULT
+#undef DOUBLE_RESULT
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompareTwoNumbers --
+ *
+ * This function compares a pair of numbers in Tcl_Objs. Each argument
+ * must already be known to be numeric and not NaN.
+ *
+ * Results:
+ * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less
+ * than, equal to, or greater than value2Ptr (respectively).
+ *
+ * Side effects:
+ * None, provided both values are numeric.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompareTwoNumbers(
+ Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr)
+{
+ int type1, type2, compare;
+ ClientData ptr1, ptr2;
+ mp_int big1, big2;
+ double d1, d2, tmp;
+ long l1, l2;
+#ifndef NO_WIDE_TYPE
+ Tcl_WideInt w1, w2;
+#endif
+
+ (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
+ (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
+
+ switch (type1) {
+ case TCL_NUMBER_LONG:
+ l1 = *((const long *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ l2 = *((const long *)ptr2);
+ longCompare:
+ return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w2 = *((const Tcl_WideInt *)ptr2);
+ w1 = (Tcl_WideInt)l1;
+ goto wideCompare;
+#endif
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((const double *)ptr2);
+ d1 = (double) l1;
+
+ /*
+ * If the double has a fractional part, or if the long can be
+ * converted to double without loss of precision, then compare as
+ * doubles.
+ */
+
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1
+ || modf(d2, &tmp) != 0.0) {
+ goto doubleCompare;
+ }
+
+ /*
+ * Otherwise, to make comparision based on full precision, need to
+ * convert the double to a suitably sized integer.
+ *
+ * Need this to get comparsions like
+ * expr 20000000000000003 < 20000000000000004.0
+ * right. Converting the first argument to double will yield two
+ * double values that are equivalent within double precision.
+ * Converting the double to an integer gets done exactly, then
+ * integer comparison can tell the difference.
+ */
+
+ if (d2 < (double)LONG_MIN) {
+ return MP_GT;
+ }
+ if (d2 > (double)LONG_MAX) {
+ return MP_LT;
+ }
+ l2 = (long) d2;
+ goto longCompare;
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
+ } else {
+ compare = MP_LT;
+ }
+ mp_clear(&big2);
+ return compare;
+ }
+
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w1 = *((const Tcl_WideInt *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_WIDE:
+ w2 = *((const Tcl_WideInt *)ptr2);
+ wideCompare:
+ return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
+ case TCL_NUMBER_LONG:
+ l2 = *((const long *)ptr2);
+ w2 = (Tcl_WideInt)l2;
+ goto wideCompare;
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((const double *)ptr2);
+ d1 = (double) w1;
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
+ || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) {
+ goto doubleCompare;
+ }
+ if (d2 < (double)LLONG_MIN) {
+ return MP_GT;
+ }
+ if (d2 > (double)LLONG_MAX) {
+ return MP_LT;
+ }
+ w2 = (Tcl_WideInt) d2;
+ goto wideCompare;
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
+ } else {
+ compare = MP_LT;
+ }
+ mp_clear(&big2);
+ return compare;
+ }
+#endif
+
+ case TCL_NUMBER_DOUBLE:
+ d1 = *((const double *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((const double *)ptr2);
+ doubleCompare:
+ return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
+ case TCL_NUMBER_LONG:
+ l2 = *((const long *)ptr2);
+ d2 = (double) l2;
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2
+ || modf(d1, &tmp) != 0.0) {
+ goto doubleCompare;
+ }
+ if (d1 < (double)LONG_MIN) {
+ return MP_LT;
+ }
+ if (d1 > (double)LONG_MAX) {
+ return MP_GT;
+ }
+ l1 = (long) d1;
+ goto longCompare;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w2 = *((const Tcl_WideInt *)ptr2);
+ d2 = (double) w2;
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
+ || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) {
+ goto doubleCompare;
+ }
+ if (d1 < (double)LLONG_MIN) {
+ return MP_LT;
+ }
+ if (d1 > (double)LLONG_MAX) {
+ return MP_GT;
+ }
+ w1 = (Tcl_WideInt) d1;
+ goto wideCompare;
+#endif
+ case TCL_NUMBER_BIG:
+ if (TclIsInfinite(d1)) {
+ return (d1 > 0.0) ? MP_GT : MP_LT;
+ }
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
+ } else {
+ compare = MP_LT;
+ }
+ mp_clear(&big2);
+ return compare;
+ }
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
+ && modf(d1, &tmp) != 0.0) {
+ d2 = TclBignumToDouble(&big2);
+ mp_clear(&big2);
+ goto doubleCompare;
+ }
+ Tcl_InitBignumFromDouble(NULL, d1, &big1);
+ goto bigCompare;
+ }
+
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
+ switch (type2) {
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+#endif
+ case TCL_NUMBER_LONG:
+ compare = mp_cmp_d(&big1, 0);
+ mp_clear(&big1);
+ return compare;
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((const double *)ptr2);
+ if (TclIsInfinite(d2)) {
+ compare = (d2 > 0.0) ? MP_LT : MP_GT;
+ mp_clear(&big1);
+ return compare;
+ }
+ if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
+ compare = mp_cmp_d(&big1, 0);
+ mp_clear(&big1);
+ return compare;
+ }
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
+ && modf(d2, &tmp) != 0.0) {
+ d1 = TclBignumToDouble(&big1);
+ mp_clear(&big1);
+ goto doubleCompare;
+ }
+ Tcl_InitBignumFromDouble(NULL, d2, &big2);
+ goto bigCompare;
+ case TCL_NUMBER_BIG:
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ bigCompare:
+ compare = mp_cmp(&big1, &big2);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ return compare;
+ }
+ default:
+ Tcl_Panic("unexpected number type");
+ return TCL_ERROR;
+ }
}
#ifdef TCL_COMPILE_DEBUG
@@ -7549,7 +7776,7 @@ TclExecuteByteCode(
* PrintByteCodeInfo --
*
* This procedure prints a summary about a bytecode object to stdout. It
- * is called by TclExecuteByteCode when starting to execute the bytecode
+ * is called by TclNRExecuteByteCode when starting to execute the bytecode
* object if tclTraceExec has the value 2 or more.
*
* Results:
@@ -7610,7 +7837,7 @@ PrintByteCodeInfo(
*
* ValidatePcAndStackTop --
*
- * This procedure is called by TclExecuteByteCode when debugging to
+ * This procedure is called by TclNRExecuteByteCode when debugging to
* verify that the program counter and stack top are valid during
* execution.
*
@@ -7629,7 +7856,7 @@ static void
ValidatePcAndStackTop(
register ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
- unsigned char *pc, /* Points to first byte of a bytecode
+ const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
@@ -7647,21 +7874,21 @@ ValidatePcAndStackTop(
unsigned char opCode = *pc;
if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {
- fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n",
+ fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
- Tcl_Panic("TclExecuteByteCode execution failure: bad pc");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if ((unsigned) opCode > LAST_INST_OPCODE) {
- fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
+ fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n",
(unsigned) opCode, relativePc);
- Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
int numChars;
- const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
@@ -7674,7 +7901,7 @@ ValidatePcAndStackTop(
} else {
fprintf(stderr, "\n");
}
- Tcl_Panic("TclExecuteByteCode execution failure: bad stack top");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top");
}
}
#endif /* TCL_COMPILE_DEBUG */
@@ -7684,7 +7911,7 @@ ValidatePcAndStackTop(
*
* IllegalExprOperandType --
*
- * Used by TclExecuteByteCode to append an error message to the interp
+ * Used by TclNRExecuteByteCode to append an error message to the interp
* result when an illegal operand type is detected by an expression
* instruction. The argument opndPtr holds the operand object in error.
*
@@ -7701,14 +7928,14 @@ static void
IllegalExprOperandType(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
- unsigned char *pc, /* Points to the instruction being executed
+ const unsigned char *pc, /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
ClientData ptr;
int type;
- unsigned char opcode = *pc;
+ const unsigned char opcode = *pc;
const char *description, *operator = operatorStrings[opcode - INST_LOR];
if (opcode == INST_EXPON) {
@@ -7773,7 +8000,7 @@ TclGetSrcInfoForCmd(
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
- codePtr, lenPtr);
+ codePtr, lenPtr, NULL);
}
void
@@ -7785,7 +8012,7 @@ TclGetSrcInfoForPc(
if (cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd = GetSrcInfoForPc(
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
- &cfPtr->cmd.str.len);
+ &cfPtr->cmd.str.len, NULL);
}
if (cfPtr->cmd.str.cmd != NULL) {
@@ -7799,14 +8026,14 @@ TclGetSrcInfoForPc(
int srcOffset, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
- eclPtr = (ExtCmdLoc *) Tcl_GetHashValue (hePtr);
+ eclPtr = Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
@@ -7836,15 +8063,18 @@ TclGetSrcInfoForPc(
static const char *
GetSrcInfoForPc(
- unsigned char *pc, /* The program counter value for which to
+ const unsigned char *pc, /* The program counter value for which to
* return the closest command's source info.
- * This points to a bytecode instruction in
+ * This points within a bytecode instruction in
* codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
- int *lengthPtr) /* If non-NULL, the location where the length
+ 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
+ * where the current instruction starts.
+ * If NULL; no pointer is stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
@@ -7856,6 +8086,7 @@ GetSrcInfoForPc(
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
+ if (pcBeg != NULL) *pcBeg = NULL;
return NULL;
}
@@ -7924,6 +8155,22 @@ GetSrcInfoForPc(
}
}
+ if (pcBeg != NULL) {
+ const unsigned char *curr,*prev;
+
+ /* Walk from beginning of command or BC to pc, by complete
+ * instructions. Stop when crossing pc; keep previous */
+
+ curr = prev = ((bestDist == INT_MAX) ?
+ codePtr->codeStart :
+ pc - bestDist);
+ while (curr <= pc) {
+ prev = curr;
+ curr += tclInstructionTable[*curr].numBytes;
+ }
+ *pcBeg = prev ;
+ }
+
if (bestDist == INT_MAX) {
return NULL;
}
@@ -7931,6 +8178,7 @@ GetSrcInfoForPc(
if (lengthPtr != NULL) {
*lengthPtr = bestSrcLength;
}
+
return (codePtr->source + bestSrcOffset);
}
@@ -7960,7 +8208,7 @@ GetSrcInfoForPc(
static ExceptionRange *
GetExceptRangeForPc(
- unsigned char *pc, /* The program counter value for which to
+ const unsigned char *pc, /* The program counter value for which to
* search for a closest enclosing exception
* range. This points to a bytecode
* instruction in codePtr's code. */
@@ -8008,7 +8256,7 @@ GetExceptRangeForPc(
* GetOpcodeName --
*
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros used
- * in TclExecuteByteCode when debugging. It returns the name of the
+ * in TclNRExecuteByteCode when debugging. It returns the name of the
* bytecode instruction at a specified instruction pc.
*
* Results:
@@ -8021,9 +8269,9 @@ GetExceptRangeForPc(
*/
#ifdef TCL_COMPILE_DEBUG
-static char *
+static const char *
GetOpcodeName(
- unsigned char *pc) /* Points to the instruction whose name should
+ const unsigned char *pc) /* Points to the instruction whose name should
* be returned. */
{
unsigned char opCode = *pc;
@@ -8195,29 +8443,29 @@ EvalStatsCmd(
"Compilation and execution statistics for interpreter %#lx\n",
iPtr);
- Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
numInstructions);
- Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n",
numInstructions / statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
totalCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->totalByteCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
totalLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8225,20 +8473,20 @@ EvalStatsCmd(
(unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
(unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
statsPtr->totalLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
numCurrentByteCodes);
- Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8246,9 +8494,9 @@ EvalStatsCmd(
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " Code + source bytes %.6g (%0.1f mean code/src)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
@@ -8261,17 +8509,17 @@ EvalStatsCmd(
numSharedMultX = 0;
Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
- Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
- Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
- Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
- Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
numSharedMultX);
/*
@@ -8308,31 +8556,31 @@ EvalStatsCmd(
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
- Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
tclObjsAlloced);
- Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
(tclObjsAlloced - tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
statsPtr->numLiteralsCreated);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
- Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
numSharedMultX);
- Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
- Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n",
(numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
- Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x %.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n",
(numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
- Tcl_AppendPrintfToObj(objPtr, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,
Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
- Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8340,13 +8588,13 @@ EvalStatsCmd(
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
- Tcl_AppendPrintfToObj(objPtr, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,
Percent(literalMgmtBytes, currentLiteralBytes));
Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
@@ -8394,7 +8642,7 @@ EvalStatsCmd(
*/
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
@@ -8406,21 +8654,21 @@ EvalStatsCmd(
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
litTableStats = TclLiteralStats(globalTablePtr);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
- ckfree((char *) litTableStats);
+ ckfree(litTableStats);
/*
* Source and ByteCode size distributions.
*/
Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
@@ -8438,12 +8686,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
@@ -8461,12 +8709,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
@@ -8484,7 +8732,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n",
decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
}
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 2b4977b..048fa57 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -11,6 +11,7 @@
*/
#include "tclInt.h"
+#include "tclFileSystem.h"
/*
* Declarations for local functions defined in this file:
@@ -21,9 +22,9 @@ static int CopyRenameOneFile(Tcl_Interp *interp,
int copyFlag, int force);
static Tcl_Obj * FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static int FileCopyRename(Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[], int copyFlag);
+ int objc, Tcl_Obj *const objv[], int copyFlag);
static int FileForceOption(Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[], int *forcePtr);
+ int objc, Tcl_Obj *const objv[], int *forcePtr);
/*
*---------------------------------------------------------------------------
@@ -46,10 +47,11 @@ static int FileForceOption(Tcl_Interp *interp,
int
TclFileRenameCmd(
+ ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
@@ -74,10 +76,11 @@ TclFileRenameCmd(
int
TclFileCopyCmd(
+ ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
@@ -103,7 +106,7 @@ static int
FileCopyRename(
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[], /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *const objv[], /* Argument strings passed to Tcl_FileCmd. */
int copyFlag) /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
@@ -111,22 +114,20 @@ FileCopyRename(
Tcl_StatBuf statBuf;
Tcl_Obj *target;
- i = FileForceOption(interp, objc - 2, objv + 2, &force);
+ i = FileForceOption(interp, objc - 1, objv + 1, &force);
if (i < 0) {
return TCL_ERROR;
}
- i += 2;
+ i++;
if ((objc - i) < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- TclGetString(objv[0]), " ", TclGetString(objv[1]),
- " ?options? source ?source ...? target\"", NULL);
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-option value ...? source ?source ...? target");
return TCL_ERROR;
}
/*
- * If target doesn't exist or isn't a directory, try the copy/rename.
- * More than 2 arguments is only valid if the target is an existing
- * directory.
+ * If target doesn't exist or isn't a directory, try the copy/rename. More
+ * than 2 arguments is only valid if the target is an existing directory.
*/
target = objv[objc - 1];
@@ -216,26 +217,25 @@ FileCopyRename(
int
TclFileMakeDirsCmd(
+ ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
- Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_Obj *errfile;
+ Tcl_Obj *errfile = NULL;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
- errfile = NULL;
-
result = TCL_OK;
- for (i = 2; i < objc; i++) {
+ for (i = 1; i < objc; i++) {
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
- split = Tcl_FSSplitPath(objv[i],&pobjc);
+ split = Tcl_FSSplitPath(objv[i], &pobjc);
Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
@@ -272,19 +272,17 @@ TclFileMakeDirsCmd(
* subdirectory.
*/
- if (errno == EEXIST) {
- if ((Tcl_FSStat(target, &statBuf) == 0)
- && S_ISDIR(statBuf.st_mode)) {
- /*
- * It is a directory that wasn't there before, so keep
- * going without error.
- */
-
- Tcl_ResetResult(interp);
- } else {
- errfile = target;
- goto done;
- }
+ if (errno != EEXIST) {
+ errfile = target;
+ goto done;
+ } else if ((Tcl_FSStat(target, &statBuf) == 0)
+ && S_ISDIR(statBuf.st_mode)) {
+ /*
+ * It is a directory that wasn't there before, so keep
+ * going without error.
+ */
+
+ Tcl_ResetResult(interp);
} else {
errfile = target;
goto done;
@@ -336,30 +334,24 @@ TclFileMakeDirsCmd(
int
TclFileDeleteCmd(
+ ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
- Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
- i = FileForceOption(interp, objc - 2, objv + 2, &force);
+ i = FileForceOption(interp, objc - 1, objv + 1, &force);
if (i < 0) {
return TCL_ERROR;
}
- i += 2;
- if ((objc - i) < 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- TclGetString(objv[0]), " ", TclGetString(objv[1]),
- " ?options? file ?file ...?\"", NULL);
- return TCL_ERROR;
- }
errfile = NULL;
result = TCL_OK;
- for ( ; i < objc; i++) {
+ for (i++ ; i < objc; i++) {
Tcl_StatBuf statBuf;
errfile = objv[i];
@@ -758,6 +750,7 @@ CopyRenameOneFile(
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
+ errfile = errorBuffer;
if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
@@ -819,27 +812,30 @@ static int
FileForceOption(
Tcl_Interp *interp, /* Interp, for error return. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[], /* Argument strings. First command line
+ Tcl_Obj *const objv[], /* Argument strings. First command line
* option, if it exists, begins at 0. */
int *forcePtr) /* If the "-force" was specified, *forcePtr is
* filled with 1, otherwise with 0. */
{
- int force, i;
+ int force, i, idx;
+ static const char *const options[] = {
+ "-force", "--", NULL
+ };
force = 0;
for (i = 0; i < objc; i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
- if (strcmp(TclGetString(objv[i]), "-force") == 0) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
+ &idx) != TCL_OK) {
+ return -1;
+ }
+ if (idx == 0 /* -force */) {
force = 1;
- } else if (strcmp(TclGetString(objv[i]), "--") == 0) {
+ } else { /* -- */
i++;
break;
- } else {
- Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
- "\": should be -force or --", NULL);
- return -1;
}
}
*forcePtr = force;
@@ -920,13 +916,13 @@ FileBasename(
* Tcl_Interp *interp; The interp to report errors with. Since
* this is an object-based API, the object
* form of the result should be used.
- * CONST char *fileName; This is extracted using
+ * const char *fileName; This is extracted using
* Tcl_TranslateFileName.
* TclObj **attrObjPtrPtr; A new object to hold the attribute is
* allocated and put here.
* The first two parameters of the callback used to write out the
* attributes are the same. The third parameter is:
- * CONST *attrObjPtr; A pointer to the object that has the new
+ * const *attrObjPtr; A pointer to the object that has the new
* attribute.
* They both return standard TCL errors; if the routine to get an
* attribute fails, no object is allocated and *attrObjPtrPtr is
@@ -943,32 +939,37 @@ FileBasename(
int
TclFileAttrsCmd(
+ ClientData clientData, /* Unused */
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
- Tcl_Obj *CONST objv[]) /* The command line objects. */
+ Tcl_Obj *const objv[]) /* The command line objects. */
{
int result;
- CONST char ** attributeStrings;
- Tcl_Obj* objStrings = NULL;
- int numObjStrings = -1, didAlloc = 0;
+ const char *const *attributeStrings;
+ const char **attributeStringsAllocated = NULL;
+ Tcl_Obj *objStrings = NULL;
+ int numObjStrings = -1;
Tcl_Obj *filePtr;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "name ?option? ?value? ?option value ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
return TCL_ERROR;
}
- filePtr = objv[2];
+ filePtr = objv[1];
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
- objc -= 3;
- objv += 3;
+ objc -= 2;
+ objv += 2;
result = TCL_ERROR;
Tcl_SetErrno(0);
+ /*
+ * Get the set of attribute names from the filesystem.
+ */
+
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
@@ -1000,18 +1001,24 @@ TclFileAttrsCmd(
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
- attributeStrings = (CONST char **) TclStackAlloc(interp,
- (1+numObjStrings) * sizeof(char*));
- didAlloc = 1;
+ attributeStringsAllocated = (const char **)
+ TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
- attributeStrings[index] = TclGetString(objPtr);
+ attributeStringsAllocated[index] = TclGetString(objPtr);
}
- attributeStrings[index] = NULL;
+ attributeStringsAllocated[index] = NULL;
+ attributeStrings = attributeStringsAllocated;
} else if (objStrings != NULL) {
Tcl_Panic("must not update objPtrRef's variable and return non-NULL");
}
+ /*
+ * Process the attributes to produce a list of all of them, the value of a
+ * particular attribute, or to set one or more attributes (depending on
+ * the number of arguments).
+ */
+
if (objc == 0) {
/*
* Get all attributes.
@@ -1052,7 +1059,7 @@ TclFileAttrsCmd(
goto end;
}
- Tcl_SetObjResult(interp, listPtr);
+ Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
* Get one attribute.
@@ -1065,6 +1072,7 @@ TclFileAttrsCmd(
Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
"\", there are no file attributes in this filesystem.",
NULL);
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
@@ -1072,9 +1080,8 @@ TclFileAttrsCmd(
"option", 0, &index) != TCL_OK) {
goto end;
}
- if (didAlloc) {
+ if (attributeStringsAllocated != NULL) {
TclFreeIntRep(objv[0]);
- objv[0]->typePtr = NULL;
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
@@ -1092,48 +1099,406 @@ TclFileAttrsCmd(
Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
"\", there are no file attributes in this filesystem.",
NULL);
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
- for (i = 0; i < objc ; i += 2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
+ for (i = 0; i < objc ; i += 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
- }
- if (didAlloc) {
+ }
+ if (attributeStringsAllocated != NULL) {
TclFreeIntRep(objv[i]);
- objv[i]->typePtr = NULL;
}
if (i + 1 == objc) {
Tcl_AppendResult(interp, "value for \"",
TclGetString(objv[i]), "\" missing", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
+ "NOVALUE", NULL);
goto end;
}
- if (Tcl_FSFileAttrsSet(interp, index, filePtr,
- objv[i + 1]) != TCL_OK) {
+ if (Tcl_FSFileAttrsSet(interp, index, filePtr,
+ objv[i + 1]) != TCL_OK) {
goto end;
- }
- }
+ }
+ }
}
result = TCL_OK;
+ /*
+ * Free up the array we allocated and drop our reference to any list of
+ * attribute names issued by the filesystem.
+ */
+
end:
- if (didAlloc) {
+ if (attributeStringsAllocated != NULL) {
+ TclStackFree(interp, (void *) attributeStringsAllocated);
+ }
+ if (objStrings != NULL) {
+ Tcl_DecrRefCount(objStrings);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFileLinkCmd --
+ *
+ * This function is invoked to process the "file link" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May create a new link.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFileLinkCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *contents;
+ int index;
+
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Index of the 'source' argument.
+ */
+
+ if (objc == 4) {
+ index = 2;
+ } else {
+ index = 1;
+ }
+
+ if (objc > 2) {
+ int linkAction;
+
+ if (objc == 4) {
+ /*
+ * We have a '-linktype' argument.
+ */
+
+ static const char *const linkTypes[] = {
+ "-symbolic", "-hard", NULL
+ };
+ if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0,
+ &linkAction) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (linkAction == 0) {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK;
+ } else {
+ linkAction = TCL_CREATE_HARD_LINK;
+ }
+ } else {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK;
+ }
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create link from source to target.
+ */
+
+ contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+ if (contents == NULL) {
+ /*
+ * We handle three common error cases specially, and for all other
+ * errors, we use the standard posix error message.
+ */
+
+ if (errno == EEXIST) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ TclGetString(objv[index]),
+ "\": that path already exists", NULL);
+ Tcl_PosixError(interp);
+ } else if (errno == ENOENT) {
+ /*
+ * There are two cases here: either the target doesn't exist,
+ * or the directory of the src doesn't exist.
+ */
+
+ int access;
+ Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
+ TCL_PATH_DIRNAME);
+
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ }
+ access = Tcl_FSAccess(dirPtr, F_OK);
+ Tcl_DecrRefCount(dirPtr);
+ if (access != 0) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ TclGetString(objv[index]),
+ "\": no such file or directory", NULL);
+ Tcl_PosixError(interp);
+ } else {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ TclGetString(objv[index]), "\": target \"",
+ TclGetString(objv[index+1]), "\" doesn't exist",
+ NULL);
+ errno = ENOENT;
+ Tcl_PosixError(interp);
+ }
+ } else {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ TclGetString(objv[index]), "\" pointing to \"",
+ TclGetString(objv[index+1]), "\": ",
+ Tcl_PosixError(interp), NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Read link
+ */
+
+ contents = Tcl_FSLink(objv[index], NULL, 0);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not read link \"",
+ TclGetString(objv[index]), "\": ", Tcl_PosixError(interp),
+ NULL);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, contents);
+ if (objc == 2) {
/*
- * Free up the array we allocated.
+ * If we are reading a link, we need to free this result refCount. If
+ * we are creating a link, this will just be objv[index+1], and so we
+ * don't own it.
*/
- TclStackFree(interp, (void *)attributeStrings);
+ Tcl_DecrRefCount(contents);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFileReadLinkCmd --
+ *
+ * This function is invoked to process the "file readlink" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFileReadLinkCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *contents;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
}
- if (objStrings != NULL) {
+ if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ contents = Tcl_FSLink(objv[1], NULL, 0);
+
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not readlink \"",
+ TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, contents);
+ Tcl_DecrRefCount(contents);
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileTemporaryCmd
+ *
+ * This function implements the "tempfile" subcommand of the "file"
+ * command.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Creates a temporary file. Opens a channel to that file and puts the
+ * name of that channel in the result. *Might* register suitable exit
+ * handlers to ensure that the temporary file gets deleted. Might write
+ * to a variable, so reentrancy is a potential issue.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFileTemporaryCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
+ * file in. */
+ Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
+ Tcl_Channel chan; /* The channel opened (RDWR) on the temporary
+ * file, or NULL if there's an error. */
+ Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL;
+ /* Pieces of template. Each piece is NULL if
+ * it is omitted. The platform temporary file
+ * engine might ignore some pieces. */
+
+ if (objc < 1 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?");
+ return TCL_ERROR;
+ }
+
+ if (objc > 1) {
+ nameVarObj = objv[1];
+ TclNewObj(nameObj);
+ }
+ if (objc > 2) {
+ int length;
+ Tcl_Obj *templateObj = objv[2];
+ const char *string = TclGetStringFromObj(templateObj, &length);
+
/*
- * We don't need this object that was passed to us any more.
+ * Treat an empty string as if it wasn't there.
*/
- Tcl_DecrRefCount(objStrings);
+ if (length == 0) {
+ goto makeTemporary;
+ }
+
+ /*
+ * The template only gives a directory if there is a directory
+ * separator in it.
+ */
+
+ if (strchr(string, '/') != NULL
+ || (tclPlatform == TCL_PLATFORM_WINDOWS
+ && strchr(string, '\\') != NULL)) {
+ tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
+
+ /*
+ * Only allow creation of temporary files in the native filesystem
+ * since they are frequently used for integration with external
+ * tools or system libraries. [Bug 2388866]
+ */
+
+ if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj)
+ != &tclNativeFilesystem) {
+ TclDecrRefCount(tempDirObj);
+ tempDirObj = NULL;
+ }
+ }
+
+ /*
+ * The template only gives the filename if the last character isn't a
+ * directory separator.
+ */
+
+ if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS
+ || string[length-1] != '\\')) {
+ Tcl_Obj *tailObj = TclPathPart(interp, templateObj,
+ TCL_PATH_TAIL);
+
+ if (tailObj != NULL) {
+ tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT);
+ tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION);
+ TclDecrRefCount(tailObj);
+ }
+ }
}
- return result;
+
+ /*
+ * Convert empty parts of the template into unspecified parts.
+ */
+
+ if (tempDirObj && !TclGetString(tempDirObj)[0]) {
+ TclDecrRefCount(tempDirObj);
+ tempDirObj = NULL;
+ }
+ if (tempBaseObj && !TclGetString(tempBaseObj)[0]) {
+ TclDecrRefCount(tempBaseObj);
+ tempBaseObj = NULL;
+ }
+ if (tempExtObj && !TclGetString(tempExtObj)[0]) {
+ TclDecrRefCount(tempExtObj);
+ tempExtObj = NULL;
+ }
+
+ /*
+ * Create and open the temporary file.
+ */
+
+ makeTemporary:
+ chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj);
+
+ /*
+ * If we created pieces of template, get rid of them now.
+ */
+
+ if (tempDirObj) {
+ TclDecrRefCount(tempDirObj);
+ }
+ if (tempBaseObj) {
+ TclDecrRefCount(tempBaseObj);
+ }
+ if (tempExtObj) {
+ TclDecrRefCount(tempExtObj);
+ }
+
+ /*
+ * Deal with results.
+ */
+
+ if (chan == NULL) {
+ if (nameVarObj) {
+ TclDecrRefCount(nameObj);
+ }
+ Tcl_AppendResult(interp, "can't create temporary file: ",
+ Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_RegisterChannel(interp, chan);
+ if (nameVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_UnregisterChannel(interp, chan);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ return TCL_OK;
}
/*
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index a8c4f42..05ecb04 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -32,11 +32,21 @@ static const char * ExtractWinRoot(const char *path,
Tcl_DString *resultPtr, int offset,
Tcl_PathType *typePtr);
static int SkipToChar(char **stringPtr, int match);
-static Tcl_Obj* SplitWinPath(const char *path);
-static Tcl_Obj* SplitUnixPath(const char *path);
+static Tcl_Obj * SplitWinPath(const char *path);
+static Tcl_Obj * SplitUnixPath(const char *path);
static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
const char *separators, Tcl_Obj *pathPtr, int flags,
char *pattern, Tcl_GlobTypeData *types);
+
+/*
+ * When there is no support for getting the block size of a file in a stat()
+ * call, use this as a guess. Allow it to be overridden in the platform-
+ * specific files.
+ */
+
+#if (!defined(HAVE_STRUCT_STAT_ST_BLKSIZE) && !defined(GUESSED_BLOCK_SIZE))
+#define GUESSED_BLOCK_SIZE 1024
+#endif
/*
*----------------------------------------------------------------------
@@ -199,7 +209,7 @@ ExtractWinRoot(
Tcl_DStringAppend(resultPtr, path, 2);
return &path[2];
} else {
- char *tail = (char*)&path[3];
+ const char *tail = &path[3];
/*
* Skip separators.
@@ -377,7 +387,7 @@ TclpGetNativePathType(
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
- char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -386,7 +396,7 @@ TclpGetNativePathType(
*/
if (driveNameLengthPtr != NULL) {
- char *end = path + 1;
+ const char *end = path + 1;
while ((*end != '\0') && (*end != '/')) {
end++;
}
@@ -395,7 +405,7 @@ TclpGetNativePathType(
} else {
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
- char *origPath = path;
+ const char *origPath = path;
/*
* Paths that begin with / are absolute.
@@ -409,7 +419,7 @@ TclpGetNativePathType(
&& (path[1] == '/') && isdigit(UCHAR(path[2]))) {
path += 3;
while (isdigit(UCHAR(*path))) {
- ++path;
+ path++;
}
}
#endif
@@ -538,7 +548,8 @@ Tcl_SplitPath(
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
int i, size, len;
- char *p, *str;
+ char *p;
+ const char *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
@@ -566,8 +577,7 @@ Tcl_SplitPath(
* plus the argv pointers and the terminating NULL pointer.
*/
- *argvPtr = (const char **) ckalloc((unsigned)
- ((((*argcPtr) + 1) * sizeof(char *)) + size));
+ *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size);
/*
* Position p after the last argv pointer and copy the contents of the
@@ -634,11 +644,12 @@ SplitUnixPath(
/*
* Check for QNX //<node id> prefix
*/
+
if ((path[0] == '/') && (path[1] == '/')
&& isdigit(UCHAR(path[2]))) { /* INTL: digit */
path += 3;
while (isdigit(UCHAR(*path))) { /* INTL: digit */
- ++path;
+ path++;
}
}
#endif
@@ -823,10 +834,12 @@ Tcl_FSJoinToPath(
void
TclpNativeJoinPath(
Tcl_Obj *prefix,
- char *joining)
+ const char *joining)
{
int length, needsSep;
- char *dest, *p, *start;
+ char *dest;
+ const char *p;
+ const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
@@ -950,7 +963,7 @@ Tcl_JoinPath(
int i, len;
Tcl_Obj *listObj = Tcl_NewObj();
Tcl_Obj *resultObj;
- char *resultStr;
+ const char *resultStr;
/*
* Build the list of paths.
@@ -1200,7 +1213,7 @@ Tcl_GlobObjCmd(
Tcl_Obj *typePtr, *resultPtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
- static const char *options[] = {
+ static const char *const options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
@@ -1245,11 +1258,14 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-directory\" cannot be used with \"-path\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
dir = PATH_DIR;
@@ -1267,11 +1283,14 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-path\" cannot be used with \"-directory\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
dir = PATH_GENERAL;
@@ -1282,6 +1301,7 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
@@ -1297,14 +1317,12 @@ Tcl_GlobObjCmd(
}
endOfForLoop:
- if (objc - i < 1) {
- Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
- return TCL_ERROR;
- }
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_AppendResult(interp,
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
@@ -1320,8 +1338,8 @@ Tcl_GlobObjCmd(
if (dir == PATH_GENERAL) {
int pathlength;
- char *last;
- char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
+ const char *last;
+ const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
@@ -1413,8 +1431,7 @@ Tcl_GlobObjCmd(
if (length <= 0) {
goto skipTypes;
}
- globTypes = (Tcl_GlobTypeData*)
- TclStackAlloc(interp,sizeof(Tcl_GlobTypeData));
+ globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
@@ -1422,7 +1439,7 @@ Tcl_GlobObjCmd(
while (--length >= 0) {
int len;
- char *str;
+ const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
@@ -1478,7 +1495,7 @@ Tcl_GlobObjCmd(
Tcl_IncrRefCount(look);
} else {
- Tcl_Obj* item;
+ Tcl_Obj *item;
if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
(len == 3)) {
@@ -1515,6 +1532,7 @@ Tcl_GlobObjCmd(
Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
Tcl_AppendObjToObj(resultPtr, look);
Tcl_SetObjResult(interp, resultPtr);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
@@ -1524,6 +1542,7 @@ Tcl_GlobObjCmd(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
join = 0;
goto endOfGlob;
}
@@ -1612,6 +1631,8 @@ Tcl_GlobObjCmd(
}
}
Tcl_AppendResult(interp, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
+ NULL);
result = TCL_ERROR;
}
}
@@ -1813,7 +1834,7 @@ TclGlob(
if (tail[0] == '/') {
tail++;
} else {
- tail+=2;
+ tail += 2;
}
Tcl_IncrRefCount(pathPrefix);
break;
@@ -1884,27 +1905,29 @@ TclGlob(
if (*tail == '\0' && pathPrefix != NULL) {
/*
- * An empty pattern. This means 'pathPrefix' is actually
- * a full path of a file/directory we want to simply check
- * for existence and type.
+ * An empty pattern. This means 'pathPrefix' is actually a full path
+ * of a file/directory we want to simply check for existence and type.
*/
+
if (types == NULL) {
/*
- * We just want to check for existence. In this case we
- * make it easy on Tcl_FSMatchInDirectory and its
- * sub-implementations by not bothering them (even though
- * they should support this situation) and we just use the
- * simple existence check with Tcl_FSAccess.
+ * We just want to check for existence. In this case we make it
+ * easy on Tcl_FSMatchInDirectory and its sub-implementations by
+ * not bothering them (even though they should support this
+ * situation) and we just use the simple existence check with
+ * Tcl_FSAccess.
*/
+
if (Tcl_FSAccess(pathPrefix, F_OK) == 0) {
Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix);
}
result = TCL_OK;
} else {
/*
- * We want to check for the correct type. Tcl_FSMatchInDirectory
+ * We want to check for the correct type. Tcl_FSMatchInDirectory
* is documented to do this for us, if we give it a NULL pattern.
*/
+
result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix,
NULL, types);
}
@@ -1969,20 +1992,20 @@ TclGlob(
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
- char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
- Tcl_Obj* elems[1];
+ const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
+ Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
- TclNewLiteralStringObj(elems[0], ".");
+ TclNewLiteralStringObj(elem, ".");
} else {
- TclNewLiteralStringObj(elems[0], "/");
+ TclNewLiteralStringObj(elem, "/");
}
} else {
- elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
+ elem = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
}
- Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
+ Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, &elem);
}
}
@@ -2097,7 +2120,7 @@ DoGlob(
* resulting filenames. Caller allocates and
* deallocates; DoGlob must not touch the
* refCount of this object. */
- const char *separators, /* String containing separator characters that
+ const char *separators, /* String containing separator characters that
* should be used to identify globbing
* boundaries. */
Tcl_Obj *pathPtr, /* Completely expanded prefix. */
@@ -2240,11 +2263,15 @@ DoGlob(
}
Tcl_SetResult(interp, "unmatched open-brace in file name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+ NULL);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetResult(interp, "unmatched close-brace in file name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+ NULL);
return TCL_ERROR;
}
}
@@ -2329,7 +2356,7 @@ DoGlob(
TCL_GLOB_TYPE_DIR, 0, NULL, NULL
};
char save = *p;
- Tcl_Obj* subdirsPtr;
+ Tcl_Obj *subdirsPtr;
if (*p == '\0') {
return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
@@ -2449,6 +2476,16 @@ DoGlob(
Tcl_DStringAppend(&append, ".", 1);
}
}
+#if defined(__CYGWIN__) && !defined(__WIN32__)
+ DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, char *);
+ {
+ char winbuf[MAXPATHLEN+1];
+
+ cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf);
+ Tcl_DStringFree(&append);
+ Tcl_DStringAppend(&append, winbuf, -1);
+ }
+#endif /* __CYGWIN__ && __WIN32__ */
break;
}
@@ -2547,7 +2584,130 @@ DoGlob(
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
- return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
+ return ckalloc(sizeof(Tcl_StatBuf));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Access functions for Tcl_StatBuf --
+ *
+ * These functions provide portable read-only access to the portable
+ * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct
+ * stat64' or something else related). [TIP #316]
+ *
+ * Results:
+ * The value from the field being retrieved.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+unsigned
+Tcl_GetFSDeviceFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_dev;
+}
+
+unsigned
+Tcl_GetFSInodeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_ino;
+}
+
+unsigned
+Tcl_GetModeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_mode;
+}
+
+int
+Tcl_GetLinkCountFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int)statPtr->st_nlink;
+}
+
+int
+Tcl_GetUserIdFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_uid;
+}
+
+int
+Tcl_GetGroupIdFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_gid;
+}
+
+int
+Tcl_GetDeviceTypeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_rdev;
+}
+
+Tcl_WideInt
+Tcl_GetAccessTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_atime;
+}
+
+Tcl_WideInt
+Tcl_GetModificationTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_mtime;
+}
+
+Tcl_WideInt
+Tcl_GetChangeTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_ctime;
+}
+
+Tcl_WideUInt
+Tcl_GetSizeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideUInt) statPtr->st_size;
+}
+
+Tcl_WideUInt
+Tcl_GetBlocksFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ return (Tcl_WideUInt) statPtr->st_blocks;
+#else
+ register unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
+
+ return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
+#endif
+}
+
+unsigned
+Tcl_GetBlockSizeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ return (unsigned) statPtr->st_blksize;
+#else
+ /*
+ * Not a great guess, but will do...
+ */
+
+ return GUESSED_BLOCK_SIZE;
+#endif
}
/*
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index 2d6f046..5e48dec 100644
--- a/generic/tclFileSystem.h
+++ b/generic/tclFileSystem.h
@@ -27,7 +27,7 @@
typedef struct FilesystemRecord {
ClientData clientData; /* Client specific data for the new filesystem
* (can be NULL) */
- Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */
+ const Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */
int fileRefCount; /* How many Tcl_Obj's use this filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered to Tcl, or
@@ -70,11 +70,11 @@ MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp,
MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp,
Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr);
MODULE_SCOPE Tcl_Obj * TclFSInternalToNormalized(
- Tcl_Filesystem *fromFilesystem,
+ const Tcl_Filesystem *fromFilesystem,
ClientData clientData,
FilesystemRecord **fsRecPtrPtr);
MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
- Tcl_Filesystem **fsPtrPtr);
+ const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr,
FilesystemRecord *fsRecPtr,
ClientData clientData);
@@ -85,7 +85,7 @@ MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp,
* Private shared variables for use by tclIOUtil.c and tclPathObj.c
*/
-MODULE_SCOPE Tcl_Filesystem tclNativeFilesystem;
+MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem;
MODULE_SCOPE Tcl_ThreadDataKey tclFsDataKey;
/*
@@ -94,24 +94,24 @@ MODULE_SCOPE Tcl_ThreadDataKey tclFsDataKey;
*/
MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr,
- Tcl_Filesystem **filesystemPtrPtr,
+ const Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr);
-MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(CONST char *pathPtr,
- int pathLen, Tcl_Filesystem **filesystemPtrPtr,
+MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr,
+ int pathLen, const Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr,
- Tcl_Filesystem **filesystemPtrPtr,
+ const Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int TclFSEpochOk(int filesystemEpoch);
MODULE_SCOPE int TclFSCwdIsNative(void);
MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp,
- CONST char *path, Tcl_Obj **useThisCwdPtr);
+ const char *path, Tcl_Obj **useThisCwdPtr);
MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep;
#endif /* _TCLFILESYSTEM */
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 54b4370..b6089d3 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -36,7 +36,7 @@
int
Tcl_GetInt(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
- CONST char *src, /* String containing a (possibly signed)
+ const char *src, /* String containing a (possibly signed)
* integer in a form acceptable to
* Tcl_GetIntFromObj(). */
int *intPtr) /* Place to store converted result. */
@@ -59,51 +59,6 @@ Tcl_GetInt(
/*
*----------------------------------------------------------------------
*
- * TclGetLong --
- *
- * Given a string, produce the corresponding long integer value. This
- * routine is a version of Tcl_GetInt but returns a "long" instead of an
- * "int" (a difference that matters on 64-bit architectures).
- *
- * Results:
- * The return value is normally TCL_OK; in this case *longPtr will be set
- * to the long integer value equivalent to src. If src is improperly
- * formed then TCL_ERROR is returned and an error message will be left in
- * the interp's result if interp is non-NULL.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclGetLong(
- Tcl_Interp *interp, /* Interpreter used for error reporting if not
- * NULL. */
- CONST char *src, /* String containing a (possibly signed) long
- * integer in a form acceptable to
- * Tcl_GetLongFromObj(). */
- long *longPtr) /* Place to store converted long result. */
-{
- Tcl_Obj obj;
- int code;
-
- obj.refCount = 1;
- obj.bytes = (char *) src;
- obj.length = strlen(src);
- obj.typePtr = NULL;
-
- code = Tcl_GetLongFromObj(interp, &obj, longPtr);
- if (obj.refCount > 1) {
- Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
- }
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_GetDouble --
*
* Given a string, produce the corresponding double-precision
@@ -124,8 +79,8 @@ TclGetLong(
int
Tcl_GetDouble(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
- CONST char *src, /* String containing a floating-point number
- * in a form acceptable to
+ const char *src, /* String containing a floating-point number
+ * in a form acceptable to
* Tcl_GetDoubleFromObj(). */
double *doublePtr) /* Place to store converted result. */
{
@@ -167,8 +122,8 @@ Tcl_GetDouble(
int
Tcl_GetBoolean(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
- CONST char *src, /* String containing one of the boolean values
- * 1, 0, true, false, yes, no, on off. */
+ const char *src, /* String containing one of the boolean values
+ * 1, 0, true, false, yes, no, on, off. */
int *boolPtr) /* Place to store converted result, which will
* be 0 or 1. */
{
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index e22e40c..da4c3fd 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -502,15 +502,11 @@ o_merid : /* NULL */ {
;
%%
-MODULE_SCOPE int yychar;
-MODULE_SCOPE YYSTYPE yylval;
-MODULE_SCOPE int yynerrs;
-
/*
* Month and day table.
*/
-static TABLE MonthDayTable[] = {
+static const TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
@@ -535,14 +531,14 @@ static TABLE MonthDayTable[] = {
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Time units table.
*/
-static TABLE UnitsTable[] = {
+static const TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
@@ -553,14 +549,14 @@ static TABLE UnitsTable[] = {
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Assorted relative-time words.
*/
-static TABLE OtherTable[] = {
+static const TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
@@ -585,7 +581,7 @@ static TABLE OtherTable[] = {
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
- { NULL }
+ { NULL, 0, 0 }
};
/*
@@ -593,7 +589,7 @@ static TABLE OtherTable[] = {
* point constants to work around an SGI compiler bug).
*/
-static TABLE TimezoneTable[] = {
+static const TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
@@ -671,14 +667,14 @@ static TABLE TimezoneTable[] = {
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
- { NULL }
+ { NULL, 0, 0 }
};
/*
* Military timezone table.
*/
-static TABLE MilitaryTable[] = {
+static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) },
{ "b", tZONE, -HOUR( 2) },
{ "c", tZONE, -HOUR( 3) },
@@ -704,7 +700,7 @@ static TABLE MilitaryTable[] = {
{ "x", tZONE, HOUR( 11) },
{ "y", tZONE, HOUR( 12) },
{ "z", tZONE, HOUR( 0) },
- { NULL }
+ { NULL, 0, 0 }
};
/*
@@ -771,7 +767,7 @@ LookupWord(
{
register char *p;
register char *q;
- register TABLE *tp;
+ register const TABLE *tp;
int i, abbrev;
/*
@@ -967,7 +963,7 @@ TclClockOldscanObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
- Tcl_Obj *CONST *objv) /* Parameters */
+ Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
@@ -1015,10 +1011,12 @@ TclClockOldscanObjCmd(
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
return TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
@@ -1026,6 +1024,7 @@ TclClockOldscanObjCmd(
"report this error as a "
"bug in Tcl.", -1));
Tcl_DecrRefCount(dateInfo.messages);
+ Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
return TCL_ERROR;
}
Tcl_DecrRefCount(dateInfo.messages);
@@ -1033,26 +1032,31 @@ TclClockOldscanObjCmd(
if (yyHaveDate > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one date in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveTime > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time of day in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveZone > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time zone in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveDay > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one weekday in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 00bfdf0..c8dc939 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -35,15 +35,15 @@
*/
#define RANDOM_INDEX(tablePtr, i) \
- (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
+ ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask)
/*
* Prototypes for the array hash key methods.
*/
-static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, VOID *keyPtr);
-static int CompareArrayKeys(VOID *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
+static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr);
+static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
+static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the one word hash key methods.
@@ -51,9 +51,9 @@ static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
#if 0
static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr,
- VOID *keyPtr);
-static int CompareOneWordKeys(VOID *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
+ void *keyPtr);
+static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr);
+static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr);
#endif
/*
@@ -61,9 +61,9 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
*/
static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr,
- VOID *keyPtr);
-static int CompareStringKeys(VOID *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashStringKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
+ void *keyPtr);
+static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
+static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Function prototypes for static functions in this file:
@@ -77,7 +77,7 @@ static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key,
static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key);
static void RebuildTable(Tcl_HashTable *tablePtr);
-Tcl_HashKeyType tclArrayHashKeyType = {
+const Tcl_HashKeyType tclArrayHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */
HashArrayKey, /* hashKeyProc */
@@ -86,7 +86,7 @@ Tcl_HashKeyType tclArrayHashKeyType = {
NULL /* freeEntryProc */
};
-Tcl_HashKeyType tclOneWordHashKeyType = {
+const Tcl_HashKeyType tclOneWordHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
NULL, /* HashOneWordKey, */ /* hashProc */
@@ -95,7 +95,7 @@ Tcl_HashKeyType tclOneWordHashKeyType = {
NULL /* FreeOneWordKey, */ /* freeEntryProc */
};
-Tcl_HashKeyType tclStringHashKeyType = {
+const Tcl_HashKeyType tclStringHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
HashStringKey, /* hashKeyProc */
@@ -122,7 +122,6 @@ Tcl_HashKeyType tclStringHashKeyType = {
*----------------------------------------------------------------------
*/
-#undef Tcl_InitHashTable
void
Tcl_InitHashTable(
register Tcl_HashTable *tablePtr,
@@ -139,7 +138,7 @@ Tcl_InitHashTable(
* extended version by a macro.
*/
- Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1);
+ Tcl_InitCustomHashTable(tablePtr, keyType, (const Tcl_HashKeyType *) -1);
}
/*
@@ -170,7 +169,7 @@ Tcl_InitCustomHashTable(
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS,
* or an integer >= 2. */
- Tcl_HashKeyType *typePtr) /* Pointer to structure which defines the
+ const Tcl_HashKeyType *typePtr) /* Pointer to structure which defines the
* behaviour of this table. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
@@ -229,7 +228,7 @@ Tcl_InitCustomHashTable(
Tcl_HashEntry *
Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key) /* Key to use to find matching entry. */
+ const void *key) /* Key to use to find matching entry. */
{
return (*((tablePtr)->findProc))(tablePtr, key);
}
@@ -267,7 +266,7 @@ FindHashEntry(
Tcl_HashEntry *
Tcl_CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key, /* Key to use to find or create matching
+ const void *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
@@ -300,15 +299,15 @@ CreateHashEntry(
}
if (typePtr->hashKeyProc) {
- hash = typePtr->hashKeyProc(tablePtr, (VOID *) key);
+ hash = typePtr->hashKeyProc(tablePtr, (void *) key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX (tablePtr, hash);
+ index = RANDOM_INDEX(tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
hash = PTR2UINT(key);
- index = RANDOM_INDEX (tablePtr, hash);
+ index = RANDOM_INDEX(tablePtr, hash);
}
/*
@@ -317,6 +316,7 @@ CreateHashEntry(
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
+
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
@@ -324,7 +324,7 @@ CreateHashEntry(
continue;
}
#endif
- if (compareKeysProc((VOID *) key, hPtr)) {
+ if (compareKeysProc((void *) key, hPtr)) {
if (newPtr) {
*newPtr = 0;
}
@@ -358,9 +358,9 @@ CreateHashEntry(
*newPtr = 1;
if (typePtr->allocEntryProc) {
- hPtr = typePtr->allocEntryProc(tablePtr, (VOID *) key);
+ hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
- hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
+ hPtr = ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
hPtr->clientData = 0;
}
@@ -371,7 +371,7 @@ CreateHashEntry(
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
#else
- hPtr->bucketPtr = &(tablePtr->buckets[index]);
+ hPtr->bucketPtr = &tablePtr->buckets[index];
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
#endif
@@ -434,12 +434,12 @@ Tcl_DeleteHashEntry(
#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX (tablePtr, entryPtr->hash);
+ index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash));
} else {
index = PTR2UINT(entryPtr->hash) & tablePtr->mask;
}
- bucketPtr = &(tablePtr->buckets[index]);
+ bucketPtr = &tablePtr->buckets[index];
#else
bucketPtr = entryPtr->bucketPtr;
#endif
@@ -460,9 +460,9 @@ Tcl_DeleteHashEntry(
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
- typePtr->freeEntryProc (entryPtr);
+ typePtr->freeEntryProc(entryPtr);
} else {
- ckfree((char *) entryPtr);
+ ckfree(entryPtr);
}
}
@@ -511,9 +511,9 @@ Tcl_DeleteHashTable(
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
- typePtr->freeEntryProc (hPtr);
+ typePtr->freeEntryProc(hPtr);
} else {
- ckfree((char *) hPtr);
+ ckfree(hPtr);
}
hPtr = nextPtr;
}
@@ -527,7 +527,7 @@ Tcl_DeleteHashTable(
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) tablePtr->buckets);
} else {
- ckfree((char *) tablePtr->buckets);
+ ckfree(tablePtr->buckets);
}
}
@@ -642,18 +642,6 @@ Tcl_HashStats(
double average, tmp;
register Tcl_HashEntry *hPtr;
char *result, *p;
- const Tcl_HashKeyType *typePtr;
-
- if (tablePtr->keyType == TCL_STRING_KEYS) {
- typePtr = &tclStringHashKeyType;
- } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
- typePtr = &tclOneWordHashKeyType;
- } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
- || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
- typePtr = tablePtr->typePtr;
- } else {
- typePtr = &tclArrayHashKeyType;
- }
/*
* Compute a histogram of bucket usage.
@@ -684,11 +672,7 @@ Tcl_HashStats(
* Print out the histogram and a few other pieces of information.
*/
- if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
- result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0);
- } else {
- result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300);
- }
+ result = ckalloc((NUM_COUNTERS * 60) + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
@@ -723,7 +707,7 @@ Tcl_HashStats(
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
- VOID *keyPtr) /* Key to store in the hash table entry. */
+ void *keyPtr) /* Key to store in the hash table entry. */
{
int *array = (int *) keyPtr;
register int *iPtr1, *iPtr2;
@@ -737,7 +721,7 @@ AllocArrayEntry(
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
- hPtr = (Tcl_HashEntry *) ckalloc(size);
+ hPtr = ckalloc(size);
for (iPtr1 = array, iPtr2 = hPtr->key.words;
count > 0; count--, iPtr1++, iPtr2++) {
@@ -767,7 +751,7 @@ AllocArrayEntry(
static int
CompareArrayKeys(
- VOID *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
register const int *iPtr1 = (const int *) keyPtr;
@@ -807,7 +791,7 @@ CompareArrayKeys(
static unsigned int
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
- VOID *keyPtr) /* Key from which to compute hash value. */
+ void *keyPtr) /* Key from which to compute hash value. */
{
register const int *array = (const int *) keyPtr;
register unsigned int result;
@@ -839,7 +823,7 @@ HashArrayKey(
static Tcl_HashEntry *
AllocStringEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
- VOID *keyPtr) /* Key to store in the hash table entry. */
+ void *keyPtr) /* Key to store in the hash table entry. */
{
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
@@ -849,7 +833,7 @@ AllocStringEntry(
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
- hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key));
+ hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
hPtr->clientData = 0;
return hPtr;
@@ -874,7 +858,7 @@ AllocStringEntry(
static int
CompareStringKeys(
- VOID *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
register const char *p1 = (const char *) keyPtr;
@@ -900,14 +884,14 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
-static unsigned int
+static unsigned
HashStringKey(
Tcl_HashTable *tablePtr, /* Hash table. */
- VOID *keyPtr) /* Key from which to compute hash value. */
+ void *keyPtr) /* Key from which to compute hash value. */
{
- register const char *string = (const char *) keyPtr;
+ register const char *string = keyPtr;
register unsigned int result;
- register int c;
+ register char c;
/*
* I tried a zillion different hash functions and asked many other people
@@ -917,19 +901,34 @@ HashStringKey(
* following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings, and
- * multiplying by 9 is just about as good.
+ * multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the hash value
- * for ever, plus they spread fairly rapidly up to the high-order bits
- * to fill out the hash value. This seems works well both for decimal
- * and non-decimal strings, but isn't strong against maliciously-chosen
- * keys.
+ * character's bits hang around in the low-order bits of the hash value
+ * for ever, plus they spread fairly rapidly up to the high-order bits
+ * to fill out the hash value. This seems works well both for decimal
+ * and non-decimal strings, but isn't strong against maliciously-chosen
+ * keys.
+ *
+ * Note that this function is very weak against malicious strings; it's
+ * very easy to generate multiple keys that have the same hashcode. On the
+ * other hand, that hardly ever actually occurs and this function *is*
+ * very cheap, even by comparison with industry-standard hashes like FNV.
+ * If real strength of hash is required though, use a custom hash based on
+ * Bob Jenkins's lookup3(), but be aware that it's significantly slower.
+ * Since Tcl command and namespace names are usually reasonably-named (the
+ * main use for string hashes in modern Tcl) speed is far more important
+ * than strength.
+ *
+ * See also HashString in tclLiteral.c.
+ * See also TclObjHashKey in tclObj.c.
+ *
+ * See [tcl-Feature Request #2958832]
*/
- result = 0;
-
- for (c=*string++ ; c ; c=*string++) {
- result += (result<<3) + c;
+ if ((result = UCHAR(*string)) != 0) {
+ while ((c = *++string) != 0) {
+ result += (result << 3) + UCHAR(c);
+ }
}
return result;
}
@@ -1043,8 +1042,8 @@ RebuildTable(
tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
} else {
- tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
- (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
+ tablePtr->buckets =
+ ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
}
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
@@ -1064,29 +1063,29 @@ RebuildTable(
#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX (tablePtr, hPtr->hash);
+ index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash));
} else {
index = PTR2UINT(hPtr->hash) & tablePtr->mask;
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
#else
- VOID *key = (VOID *) Tcl_GetHashKey(tablePtr, hPtr);
+ void *key = Tcl_GetHashKey(tablePtr, hPtr);
if (typePtr->hashKeyProc) {
unsigned int hash;
hash = typePtr->hashKeyProc(tablePtr, key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX (tablePtr, hash);
+ index = RANDOM_INDEX(tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
- index = RANDOM_INDEX (tablePtr, key);
+ index = RANDOM_INDEX(tablePtr, key);
}
- hPtr->bucketPtr = &(tablePtr->buckets[index]);
+ hPtr->bucketPtr = &tablePtr->buckets[index];
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
#endif
@@ -1101,7 +1100,7 @@ RebuildTable(
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) oldBuckets);
} else {
- ckfree((char *) oldBuckets);
+ ckfree(oldBuckets);
}
}
}
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index a23e102..b10d423 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -14,6 +14,24 @@
*/
#include "tclInt.h"
+
+/*
+ * Type of the assocData structure used to hold the reference to the [history
+ * add] subcommand, used in Tcl_RecordAndEvalObj.
+ */
+
+typedef struct {
+ Tcl_Obj *historyObj; /* == "::history" */
+ Tcl_Obj *addObj; /* == "add" */
+} HistoryObjs;
+
+#define HISTORY_OBJS_KEY "::tcl::HistoryObjs"
+
+/*
+ * Static functions in this file.
+ */
+
+static Tcl_InterpDeleteProc DeleteHistoryObjs;
/*
*----------------------------------------------------------------------
@@ -37,7 +55,7 @@ int
Tcl_RecordAndEval(
Tcl_Interp *interp, /* Token for interpreter in which command will
* be executed. */
- CONST char *cmd, /* Command to record. */
+ const char *cmd, /* Command to record. */
int flags) /* Additional flags. TCL_NO_EVAL means only
* record: don't execute command.
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
@@ -111,36 +129,49 @@ Tcl_RecordAndEvalObj(
* current procedure. */
{
int result, call = 1;
- Tcl_Obj *list[3];
- register Tcl_Obj *objPtr;
Tcl_CmdInfo info;
+ HistoryObjs *histObjsPtr =
+ Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
- * Do not call [history] if it has been replaced by an empty proc
+ * Create the references to the [::history add] command if necessary.
*/
- result = Tcl_GetCommandInfo(interp, "history", &info);
+ if (histObjsPtr == NULL) {
+ histObjsPtr = ckalloc(sizeof(HistoryObjs));
+ TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
+ TclNewLiteralStringObj(histObjsPtr->addObj, "add");
+ Tcl_IncrRefCount(histObjsPtr->historyObj);
+ Tcl_IncrRefCount(histObjsPtr->addObj);
+ Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
+ histObjsPtr);
+ }
+
+ /*
+ * Do not call [history] if it has been replaced by an empty proc
+ */
- if (result && (info.objProc == TclObjInterpProc)) {
- Proc *procPtr = (Proc *)(info.objClientData);
+ result = Tcl_GetCommandInfo(interp, "::history", &info);
+ if (result && (info.deleteProc == TclProcDeleteProc)) {
+ Proc *procPtr = (Proc *) info.objClientData;
call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
}
if (call) {
+ Tcl_Obj *list[3];
/*
* Do recording by eval'ing a tcl history command: history add $cmd.
*/
- TclNewLiteralStringObj(list[0], "history");
- TclNewLiteralStringObj(list[1], "add");
+ list[0] = histObjsPtr->historyObj;
+ list[1] = histObjsPtr->addObj;
list[2] = cmdPtr;
-
- objPtr = Tcl_NewListObj(3, list);
- Tcl_IncrRefCount(objPtr);
- (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(objPtr);
-
+
+ Tcl_IncrRefCount(cmdPtr);
+ (void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(cmdPtr);
+
/*
* One possible failure mode above: exceeding a resource limit.
*/
@@ -162,6 +193,35 @@ Tcl_RecordAndEvalObj(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteHistoryObjs --
+ *
+ * Called to delete the references to the constant words used when adding
+ * to the history.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The constant words may be deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteHistoryObjs(
+ ClientData clientData,
+ Tcl_Interp *interp)
+{
+ register HistoryObjs *histObjsPtr = clientData;
+
+ TclDecrRefCount(histObjsPtr->historyObj);
+ TclDecrRefCount(histObjsPtr->addObj);
+ ckfree(histObjsPtr);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 0f01baa..c7fab6c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -60,6 +60,9 @@ static void CleanupChannelHandlers(Tcl_Interp *interp,
Channel *chanPtr);
static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
int errorCode);
+static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
+ int errorCode, int flags);
+static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void CommonGetsCleanup(Channel *chanPtr);
static int CopyAndTranslateBuffer(ChannelState *statePtr,
char *result, int space);
@@ -115,6 +118,7 @@ static int WriteChars(Channel *chanPtr, const char *src,
static Tcl_Obj * FixLevelCode(Tcl_Obj *msg);
static void SpliceChannel(Tcl_Channel chan);
static void CutChannel(Tcl_Channel chan);
+static int WillRead(Channel *chanPtr);
/*
* Simplifying helper macros. All may use their argument(s) multiple times.
@@ -160,21 +164,21 @@ static void CutChannel(Tcl_Channel chan);
* --------------------------------------------------------------------------
*/
-#define BytesLeft(bufPtr) ((bufPtr)->nextAdded - (bufPtr)->nextRemoved)
+#define BytesLeft(bufPtr) ((bufPtr)->nextAdded - (bufPtr)->nextRemoved)
-#define SpaceLeft(bufPtr) ((bufPtr)->bufLength - (bufPtr)->nextAdded)
+#define SpaceLeft(bufPtr) ((bufPtr)->bufLength - (bufPtr)->nextAdded)
-#define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved)
+#define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved)
-#define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved)
+#define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved)
-#define IsBufferFull(bufPtr) ((bufPtr)->nextAdded >= (bufPtr)->bufLength)
+#define IsBufferFull(bufPtr) ((bufPtr)->nextAdded >= (bufPtr)->bufLength)
-#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->bufLength)
+#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength)
-#define InsertPoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextAdded)
+#define InsertPoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextAdded)
-#define RemovePoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextRemoved)
+#define RemovePoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextRemoved)
/*
* For working with channel state flag bits.
@@ -182,6 +186,7 @@ static void CutChannel(Tcl_Channel chan);
#define SetFlag(statePtr, flag) ((statePtr)->flags |= (flag))
#define ResetFlag(statePtr, flag) ((statePtr)->flags &= ~(flag))
+#define GotFlag(statePtr, flag) ((statePtr)->flags & (flag))
/*
* Macro for testing whether a string (in optionName, length len) matches a
@@ -202,11 +207,12 @@ static void CutChannel(Tcl_Channel chan);
*/
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
-static int SetChannelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static int SetChannelFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
static void UpdateStringOfChannel(Tcl_Obj *objPtr);
static void FreeChannelIntRep(Tcl_Obj *objPtr);
-static Tcl_ObjType tclChannelType = {
+static const Tcl_ObjType tclChannelType = {
"channel", /* name for this type */
FreeChannelIntRep, /* freeIntRepProc */
DupChannelIntRep, /* dupIntRepProc */
@@ -223,7 +229,7 @@ static Tcl_ObjType tclChannelType = {
#define SET_CHANNELINTERP(objPtr, storePtr) \
((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr))
-#define BUSY_STATE(st,fl) \
+#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -232,6 +238,113 @@ static Tcl_ObjType tclChannelType = {
/*
*---------------------------------------------------------------------------
*
+ * ChanClose, ChanRead, ChanSeek, ChanThreadAction, ChanWatch, ChanWrite --
+ *
+ * Simplify the access to selected channel driver "methods" that are used
+ * in multiple places in a stereotypical fashion. These are just thin
+ * wrappers around the driver functions.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static inline int
+ChanClose(
+ Channel *chanPtr,
+ Tcl_Interp *interp)
+{
+ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
+ return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp);
+ } else {
+ return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
+ }
+}
+
+static inline int
+ChanCloseHalf(
+ Channel *chanPtr,
+ Tcl_Interp *interp,
+ int flags)
+{
+ return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags);
+}
+
+static inline int
+ChanRead(
+ Channel *chanPtr,
+ char *dst,
+ int dstSize,
+ int *errnoPtr)
+{
+ if (WillRead(chanPtr) < 0) {
+ return -1;
+ }
+
+ return chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize,
+ errnoPtr);
+}
+
+static inline Tcl_WideInt
+ChanSeek(
+ Channel *chanPtr,
+ Tcl_WideInt offset,
+ int mode,
+ int *errnoPtr)
+{
+ /*
+ * Note that we prefer the wideSeekProc if that field is available in the
+ * type and non-NULL.
+ */
+
+ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
+ chanPtr->typePtr->wideSeekProc != NULL) {
+ return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData,
+ offset, mode, errnoPtr);
+ }
+
+ if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
+ *errnoPtr = EOVERFLOW;
+ return Tcl_LongAsWide(-1);
+ }
+
+ return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData,
+ Tcl_WideAsLong(offset), mode, errnoPtr));
+}
+
+static inline void
+ChanThreadAction(
+ Channel *chanPtr,
+ int action)
+{
+ Tcl_DriverThreadActionProc *threadActionProc =
+ Tcl_ChannelThreadActionProc(chanPtr->typePtr);
+
+ if (threadActionProc != NULL) {
+ threadActionProc(chanPtr->instanceData, action);
+ }
+}
+
+static inline void
+ChanWatch(
+ Channel *chanPtr,
+ int mask)
+{
+ chanPtr->typePtr->watchProc(chanPtr->instanceData, mask);
+}
+
+static inline int
+ChanWrite(
+ Channel *chanPtr,
+ const char *src,
+ int srcLen,
+ int *errnoPtr)
+{
+ return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen,
+ errnoPtr);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* TclInitIOSubsystem --
*
* Initialize all resources used by this subsystem on a per-process
@@ -301,7 +414,8 @@ TclFinalizeIOSubsystem(void)
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
- if (!(statePtr->flags & (CHANNEL_INCLOSE|CHANNEL_CLOSED|CHANNEL_DEAD))) {
+ if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED |
+ CHANNEL_DEAD)) {
active = 1;
break;
}
@@ -351,12 +465,7 @@ TclFinalizeIOSubsystem(void)
* device for this channel.
*/
- if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
- (chanPtr->typePtr->closeProc)(chanPtr->instanceData, NULL);
- } else {
- (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
- NULL, 0);
- }
+ (void) ChanClose(chanPtr, NULL);
/*
* Finally, we clean up the fields in the channel data
@@ -398,6 +507,7 @@ Tcl_SetStdChannel(
int type) /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
switch (type) {
case TCL_STDIN:
tsdPtr->stdinInitialized = 1;
@@ -514,12 +624,10 @@ Tcl_CreateCloseHandler(
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
- ChannelState *statePtr;
+ ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
- statePtr = ((Channel *) chan)->state;
-
- cbPtr = (CloseCallback *) ckalloc(sizeof(CloseCallback));
+ cbPtr = ckalloc(sizeof(CloseCallback));
cbPtr->proc = proc;
cbPtr->clientData = clientData;
@@ -554,21 +662,19 @@ Tcl_DeleteCloseHandler(
ClientData clientData) /* The callback data for the callback to
* remove. */
{
- ChannelState *statePtr;
+ ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr, *cbPrevPtr;
- statePtr = ((Channel *) chan)->state;
for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = NULL;
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
}
- ckfree((char *) cbPtr);
+ ckfree(cbPtr);
break;
- } else {
- cbPrevPtr = cbPtr;
}
+ cbPrevPtr = cbPtr;
}
}
@@ -600,7 +706,7 @@ GetChannelTable(
hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
- hTblPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ hTblPtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclIO",
(Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr);
@@ -689,10 +795,10 @@ DeleteChannelTable(
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) sPtr);
+ TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
- ckfree((char *) sPtr);
+ ckfree(sPtr);
} else {
prevPtr = sPtr;
}
@@ -709,14 +815,14 @@ DeleteChannelTable(
SetFlag(statePtr, CHANNEL_TAINTED);
statePtr->refCount--;
if (statePtr->refCount <= 0) {
- if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
+ if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
- ckfree((char *) hTblPtr);
+ ckfree(hTblPtr);
}
/*
@@ -748,21 +854,19 @@ CheckForStdChannelsBeingClosed(
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if ((chan == tsdPtr->stdinChannel) && (tsdPtr->stdinInitialized)) {
+ if ((chan == tsdPtr->stdinChannel) && tsdPtr->stdinInitialized) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdinChannel = NULL;
return;
}
- } else if ((chan == tsdPtr->stdoutChannel)
- && (tsdPtr->stdoutInitialized)) {
+ } else if ((chan == tsdPtr->stdoutChannel) && tsdPtr->stdoutInitialized) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdoutChannel = NULL;
return;
}
- } else if ((chan == tsdPtr->stderrChannel)
- && (tsdPtr->stderrInitialized)) {
+ } else if ((chan == tsdPtr->stderrChannel) && tsdPtr->stderrInitialized) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
@@ -896,7 +1000,7 @@ Tcl_UnregisterChannel(
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
- if (statePtr->flags & CHANNEL_INCLOSE) {
+ if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
Tcl_AppendResult(interp, "Illegal recursive call to close "
"through close-handler of channel", NULL);
@@ -934,22 +1038,22 @@ Tcl_UnregisterChannel(
IsBufferReady(statePtr->curOutPtr)) {
SetFlag(statePtr, BUFFER_READY);
}
- Tcl_Preserve((ClientData)statePtr);
- if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
+ Tcl_Preserve(statePtr);
+ if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
/*
* We don't want to re-enter Tcl_Close().
*/
- if (!(statePtr->flags & CHANNEL_CLOSED)) {
+ if (!GotFlag(statePtr, CHANNEL_CLOSED)) {
if (Tcl_Close(interp, chan) != TCL_OK) {
SetFlag(statePtr, CHANNEL_CLOSED);
- Tcl_Release((ClientData)statePtr);
+ Tcl_Release(statePtr);
return TCL_ERROR;
}
}
}
SetFlag(statePtr, CHANNEL_CLOSED);
- Tcl_Release((ClientData)statePtr);
+ Tcl_Release(statePtr);
}
return TCL_OK;
}
@@ -1149,7 +1253,7 @@ Tcl_GetChannel(
chanPtr = Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE));
+ *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE);
}
return (Tcl_Channel) chanPtr;
@@ -1194,10 +1298,10 @@ TclGetChannelFromObj(
}
statePtr = GET_CHANNELSTATE(objPtr);
- *channelPtr = (Tcl_Channel) (statePtr->bottomChanPtr);
+ *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));
+ *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE);
}
return TCL_OK;
@@ -1221,7 +1325,7 @@ TclGetChannelFromObj(
Tcl_Channel
Tcl_CreateChannel(
- Tcl_ChannelType *typePtr, /* The channel type record. */
+ const Tcl_ChannelType *typePtr, /* The channel type record. */
const char *chanName, /* Name of channel to record. */
ClientData instanceData, /* Instance specific data. */
int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if
@@ -1231,6 +1335,7 @@ Tcl_CreateChannel(
ChannelState *statePtr; /* The stack-level independent state info for
* the channel. */
const char *name;
+ char *tmp;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
@@ -1243,15 +1348,15 @@ Tcl_CreateChannel(
* as well.
*/
- assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));
+ assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
* assignments to 0/NULL below.
*/
- chanPtr = (Channel *) ckalloc(sizeof(Channel));
- statePtr = (ChannelState *) ckalloc(sizeof(ChannelState));
+ chanPtr = ckalloc(sizeof(Channel));
+ statePtr = ckalloc(sizeof(ChannelState));
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
@@ -1263,14 +1368,20 @@ Tcl_CreateChannel(
*/
if (chanName != NULL) {
- char *tmp = ckalloc((unsigned) (strlen(chanName) + 1));
+ unsigned len = strlen(chanName) + 1;
+
+ /*
+ * Make sure we allocate at least 7 bytes, so it fits for "stdout"
+ * later.
+ */
- statePtr->channelName = tmp;
+ tmp = ckalloc((len < 7) ? 7 : len);
strcpy(tmp, chanName);
} else {
- Tcl_Panic("Tcl_CreateChannel: NULL channel name");
+ tmp = ckalloc(7);
+ tmp[0] = '\0';
}
-
+ statePtr->channelName = tmp;
statePtr->flags = mask;
/*
@@ -1324,9 +1435,8 @@ Tcl_CreateChannel(
statePtr->csPtrW = NULL;
statePtr->outputStage = NULL;
- if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
- statePtr->outputStage = (char *)
- ckalloc((unsigned) (statePtr->bufSize + 2));
+ if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
+ statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
}
/*
@@ -1373,14 +1483,17 @@ Tcl_CreateChannel(
*/
if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) {
+ strcpy(tmp, "stdin");
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stdoutChannel == NULL) &&
(tsdPtr->stdoutInitialized == 1)) {
+ strcpy(tmp, "stdout");
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stderrChannel == NULL) &&
(tsdPtr->stderrInitialized == 1)) {
+ strcpy(tmp, "stderr");
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr);
}
@@ -1417,7 +1530,8 @@ Tcl_CreateChannel(
Tcl_Channel
Tcl_StackChannel(
Tcl_Interp *interp, /* The interpreter we are working in */
- Tcl_ChannelType *typePtr, /* The channel type record for the new
+ const Tcl_ChannelType *typePtr,
+ /* The channel type record for the new
* channel. */
ClientData instanceData, /* Instance specific data for the new
* channel. */
@@ -1428,7 +1542,6 @@ Tcl_StackChannel(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr, *prevChanPtr;
ChannelState *statePtr;
- Tcl_DriverThreadActionProc *threadActionProc;
/*
* Find the given channel (prevChan) in the list of all channels. If we do
@@ -1482,13 +1595,10 @@ Tcl_StackChannel(
*/
if ((mask & TCL_WRITABLE) != 0) {
- CopyState *csPtrR;
- CopyState *csPtrW;
+ CopyState *csPtrR = statePtr->csPtrR;
+ CopyState *csPtrW = statePtr->csPtrW;
- csPtrR = statePtr->csPtrR;
statePtr->csPtrR = NULL;
-
- csPtrW = statePtr->csPtrW;
statePtr->csPtrW = NULL;
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
@@ -1537,7 +1647,7 @@ Tcl_StackChannel(
statePtr->inQueueTail = NULL;
}
- chanPtr = (Channel *) ckalloc(sizeof(Channel));
+ chanPtr = ckalloc(sizeof(Channel));
/*
* Save some of the current state into the new structure, reinitialize the
@@ -1573,10 +1683,7 @@ Tcl_StackChannel(
* time, mangling it.
*/
- threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
- if (threadActionProc != NULL) {
- (*threadActionProc)(chanPtr->instanceData, TCL_CHANNEL_THREAD_INSERT);
- }
+ ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT);
return (Tcl_Channel) chanPtr;
}
@@ -1607,7 +1714,6 @@ Tcl_UnstackChannel(
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
int result = 0;
- Tcl_DriverThreadActionProc *threadActionProc;
/*
* This operation should occur at the top of a channel stack.
@@ -1618,9 +1724,9 @@ Tcl_UnstackChannel(
if (chanPtr->downChanPtr != NULL) {
/*
* Instead of manipulating the per-thread / per-interp list/hashtable
- * of registered channels we wind down the state of the transformation,
- * and then restore the state of underlying channel into the old
- * structure.
+ * of registered channels we wind down the state of the
+ * transformation, and then restore the state of underlying channel
+ * into the old structure.
*/
Channel *downChanPtr = chanPtr->downChanPtr;
@@ -1633,14 +1739,11 @@ Tcl_UnstackChannel(
* CheckForChannelErrors inside.
*/
- if (statePtr->flags & TCL_WRITABLE) {
- CopyState *csPtrR;
- CopyState *csPtrW;
+ if (GotFlag(statePtr, TCL_WRITABLE)) {
+ CopyState *csPtrR = statePtr->csPtrR;
+ CopyState *csPtrW = statePtr->csPtrW;
- csPtrR = statePtr->csPtrR;
statePtr->csPtrR = NULL;
-
- csPtrW = statePtr->csPtrW;
statePtr->csPtrW = NULL;
if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
@@ -1677,16 +1780,14 @@ Tcl_UnstackChannel(
* 'DiscardInputQueued' on that.
*/
- if ((((statePtr->flags & TCL_READABLE) != 0)) &&
+ if (GotFlag(statePtr, TCL_READABLE) &&
((statePtr->inQueueHead != NULL) ||
(chanPtr->inQueueHead != NULL))) {
-
if ((statePtr->inQueueHead != NULL) &&
(chanPtr->inQueueHead != NULL)) {
statePtr->inQueueTail->nextPtr = chanPtr->inQueueHead;
statePtr->inQueueTail = chanPtr->inQueueTail;
statePtr->inQueueHead = statePtr->inQueueTail;
-
} else if (chanPtr->inQueueHead != NULL) {
statePtr->inQueueHead = chanPtr->inQueueHead;
statePtr->inQueueTail = chanPtr->inQueueTail;
@@ -1710,11 +1811,7 @@ Tcl_UnstackChannel(
* the state which are still active.
*/
- threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
- if (threadActionProc != NULL) {
- (*threadActionProc)(chanPtr->instanceData,
- TCL_CHANNEL_THREAD_REMOVE);
- }
+ ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
statePtr->topChanPtr = downChanPtr;
downChanPtr->upChanPtr = NULL;
@@ -1728,14 +1825,7 @@ Tcl_UnstackChannel(
* Close and free the channel driver state.
*/
- if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
- result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData,
- interp);
- } else {
- result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
- interp, 0);
- }
-
+ result = ChanClose(chanPtr, interp);
chanPtr->typePtr = NULL;
/*
@@ -1911,7 +2001,7 @@ Tcl_GetChannelThread(
*----------------------------------------------------------------------
*/
-Tcl_ChannelType *
+const Tcl_ChannelType *
Tcl_GetChannelType(
Tcl_Channel chan) /* The channel to return type for. */
{
@@ -1970,9 +2060,9 @@ const char *
Tcl_GetChannelName(
Tcl_Channel chan) /* The channel for which to return the name. */
{
- ChannelState *statePtr; /* State of actual channel. */
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of actual channel. */
- statePtr = ((Channel *) chan)->state;
return statePtr->channelName;
}
@@ -2005,15 +2095,16 @@ Tcl_GetChannelHandle(
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
if (!chanPtr->typePtr->getHandleProc) {
- Tcl_Obj* err;
+ Tcl_Obj *err;
+
TclNewLiteralStringObj(err, "channel \"");
Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1);
Tcl_AppendToObj(err, "\" does not support OS handles", -1);
- Tcl_SetChannelError (chan,err);
+ Tcl_SetChannelError(chan, err);
return TCL_ERROR;
}
- result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData,
- direction, &handle);
+ result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
+ &handle);
if (handlePtr) {
*handlePtr = handle;
}
@@ -2052,7 +2143,7 @@ AllocChannelBuffer(
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
- bufPtr = (ChannelBuffer *) ckalloc((unsigned) n);
+ bufPtr = ckalloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
@@ -2091,7 +2182,7 @@ RecycleBuffer(
*/
if (mustDiscard) {
- ckfree((char *) bufPtr);
+ ckfree(bufPtr);
return;
}
@@ -2102,7 +2193,7 @@ RecycleBuffer(
*/
if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
- ckfree((char *) bufPtr);
+ ckfree(bufPtr);
return;
}
@@ -2110,7 +2201,7 @@ RecycleBuffer(
* Only save buffers for the input queue if the channel is readable.
*/
- if (statePtr->flags & TCL_READABLE) {
+ if (GotFlag(statePtr, TCL_READABLE)) {
if (statePtr->inQueueHead == NULL) {
statePtr->inQueueHead = bufPtr;
statePtr->inQueueTail = bufPtr;
@@ -2126,7 +2217,7 @@ RecycleBuffer(
* Only save buffers for the output queue if the channel is writable.
*/
- if (statePtr->flags & TCL_WRITABLE) {
+ if (GotFlag(statePtr, TCL_WRITABLE)) {
if (statePtr->curOutPtr == NULL) {
statePtr->curOutPtr = bufPtr;
goto keepBuffer;
@@ -2137,7 +2228,7 @@ RecycleBuffer(
* If we reached this code we return the buffer to the OS.
*/
- ckfree((char *) bufPtr);
+ ckfree(bufPtr);
return;
keepBuffer:
@@ -2199,15 +2290,16 @@ CheckForDeadChannel(
Tcl_Interp *interp, /* For error reporting (can be NULL) */
ChannelState *statePtr) /* The channel state to check. */
{
- if (statePtr->flags & CHANNEL_DEAD) {
- Tcl_SetErrno(EINVAL);
- if (interp) {
- Tcl_AppendResult(interp,
- "unable to access channel: invalid channel", NULL);
- }
- return 1;
+ if (!GotFlag(statePtr, CHANNEL_DEAD)) {
+ return 0;
}
- return 0;
+
+ Tcl_SetErrno(EINVAL);
+ if (interp) {
+ Tcl_AppendResult(interp, "unable to access channel: invalid channel",
+ NULL);
+ }
+ return 1;
}
/*
@@ -2215,9 +2307,9 @@ CheckForDeadChannel(
*
* FlushChannel --
*
- * This function flushes as much of the queued output as is possible
- * now. If calledFromAsyncFlush is nonzero, it is being called in an
- * event handler to flush channel output asynchronously.
+ * This function flushes as much of the queued output as is possible now.
+ * If calledFromAsyncFlush is nonzero, it is being called in an event
+ * handler to flush channel output asynchronously.
*
* Results:
* 0 if successful, else the error code that was returned by the channel
@@ -2275,7 +2367,7 @@ FlushChannel(
if (((statePtr->curOutPtr != NULL) &&
IsBufferFull(statePtr->curOutPtr))
- || ((statePtr->flags & BUFFER_READY) &&
+ || (GotFlag(statePtr, BUFFER_READY) &&
(statePtr->outQueueHead == NULL))) {
ResetFlag(statePtr, BUFFER_READY);
statePtr->curOutPtr->nextPtr = NULL;
@@ -2294,8 +2386,7 @@ FlushChannel(
* is active, we just return without producing any output.
*/
- if ((!calledFromAsyncFlush) &&
- (statePtr->flags & BG_FLUSH_SCHEDULED)) {
+ if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
return 0;
}
@@ -2304,7 +2395,7 @@ FlushChannel(
*/
if (bufPtr == NULL) {
- break; /* Out of the "while (1)". */
+ break; /* Out of the "while (1)". */
}
/*
@@ -2313,10 +2404,10 @@ FlushChannel(
toWrite = BytesLeft(bufPtr);
if (toWrite == 0) {
- written = 0;
+ written = 0;
} else {
- written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData,
- RemovePoint(bufPtr), toWrite, &errorCode);
+ written = ChanWrite(chanPtr, RemovePoint(bufPtr), toWrite,
+ &errorCode);
}
/*
@@ -2348,7 +2439,7 @@ FlushChannel(
* it's a tty channel (dup'ed underneath)
*/
- if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
+ if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
SetFlag(statePtr, BG_FLUSH_SCHEDULED);
UpdateInterest(chanPtr);
}
@@ -2398,14 +2489,8 @@ FlushChannel(
Tcl_SetErrno(errorCode);
if (interp != NULL && !TclChanCaughtErrorBypass(interp,
(Tcl_Channel) chanPtr)) {
- /*
- * Casting away const here is safe because the
- * TCL_VOLATILE flag guarantees const treatment of the
- * Posix error string.
- */
-
- Tcl_SetResult(interp, (char *) Tcl_PosixError(interp),
- TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
/*
@@ -2447,13 +2532,12 @@ FlushChannel(
* data has been flushed at the system level.
*/
- if (statePtr->flags & BG_FLUSH_SCHEDULED) {
+ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
if (wroteSome) {
return errorCode;
} else if (statePtr->outQueueHead == NULL) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
- (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
- statePtr->interestMask);
+ ChanWatch(chanPtr, statePtr->interestMask);
}
}
@@ -2463,12 +2547,25 @@ FlushChannel(
* current output buffer.
*/
- if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
+ if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
return CloseChannel(interp, chanPtr, errorCode);
}
+
+ /*
+ * If the write-side of the channel is flagged as closed, delete it when
+ * the output queue is empty and there is no output in the current output
+ * buffer.
+ */
+
+ if (GotFlag(statePtr, CHANNEL_CLOSEDWRITE) &&
+ (statePtr->outQueueHead == NULL) &&
+ ((statePtr->curOutPtr == NULL) ||
+ IsBufferEmpty(statePtr->curOutPtr))) {
+ return CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE);
+ }
return errorCode;
}
@@ -2522,7 +2619,7 @@ CloseChannel(
*/
if (statePtr->curOutPtr != NULL) {
- ckfree((char *) statePtr->curOutPtr);
+ ckfree(statePtr->curOutPtr);
statePtr->curOutPtr = NULL;
}
@@ -2539,11 +2636,11 @@ CloseChannel(
* device.
*/
- if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) {
+ if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) {
int dummy;
char c = (char) statePtr->outEofChar;
- (chanPtr->typePtr->outputProc)(chanPtr->instanceData, &c, 1, &dummy);
+ (void) ChanWrite(chanPtr, &c, 1, &dummy);
}
/*
@@ -2554,7 +2651,7 @@ CloseChannel(
if (statePtr->chanMsg != NULL) {
if (interp != NULL) {
- Tcl_SetChannelErrorInterp(interp,statePtr->chanMsg);
+ Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg);
}
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
@@ -2571,12 +2668,7 @@ CloseChannel(
* This may leave a TIP #219 error message in the interp.
*/
- if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
- result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
- } else {
- result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
- interp, 0);
- }
+ result = ChanClose(chanPtr, interp);
/*
* Some resources can be cleared only if the bottom channel in a stack is
@@ -2585,13 +2677,13 @@ CloseChannel(
if (chanPtr == statePtr->bottomChanPtr) {
if (statePtr->channelName != NULL) {
- ckfree((char *) statePtr->channelName);
+ ckfree(statePtr->channelName);
statePtr->channelName = NULL;
}
Tcl_FreeEncoding(statePtr->encoding);
if (statePtr->outputStage != NULL) {
- ckfree((char *) statePtr->outputStage);
+ ckfree(statePtr->outputStage);
statePtr->outputStage = NULL;
}
}
@@ -2615,7 +2707,7 @@ CloseChannel(
statePtr->chanMsg = NULL;
}
if (interp) {
- Tcl_SetChannelErrorInterp(interp,statePtr->unreportedMsg);
+ Tcl_SetChannelErrorInterp(interp, statePtr->unreportedMsg);
}
}
if (errorCode == 0) {
@@ -2700,7 +2792,6 @@ CutChannel(
* the list on close. */
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of the channel stack. */
- Tcl_DriverThreadActionProc *threadActionProc;
/*
* Remove this channel from of the list of all channels (in the current
@@ -2727,11 +2818,7 @@ CutChannel(
* TIP #218, Channel Thread Actions
*/
- threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
- if (threadActionProc != NULL) {
- (*threadActionProc)(Tcl_GetChannelInstanceData(chan),
- TCL_CHANNEL_THREAD_REMOVE);
- }
+ ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
}
void
@@ -2746,7 +2833,6 @@ Tcl_CutChannel(
* the list on close. */
ChannelState *statePtr = chanPtr->state;
/* State of the channel stack. */
- Tcl_DriverThreadActionProc *threadActionProc;
/*
* Remove this channel from of the list of all channels (in the current
@@ -2774,13 +2860,8 @@ Tcl_CutChannel(
* For all transformations and the base channel.
*/
- while (chanPtr) {
- threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
- if (threadActionProc != NULL) {
- (*threadActionProc)(chanPtr->instanceData,
- TCL_CHANNEL_THREAD_REMOVE);
- }
- chanPtr= chanPtr->upChanPtr;
+ for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
+ ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
}
@@ -2817,7 +2898,6 @@ SpliceChannel(
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *statePtr = ((Channel *) chan)->state;
- Tcl_DriverThreadActionProc *threadActionProc;
if (statePtr->nextCSPtr != NULL) {
Tcl_Panic("SpliceChannel: trying to add channel used in different list");
@@ -2838,11 +2918,7 @@ SpliceChannel(
* TIP #218, Channel Thread Actions
*/
- threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
- if (threadActionProc != NULL) {
- (*threadActionProc) (Tcl_GetChannelInstanceData(chan),
- TCL_CHANNEL_THREAD_INSERT);
- }
+ ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_INSERT);
}
void
@@ -2853,7 +2929,6 @@ Tcl_SpliceChannel(
Channel *chanPtr = ((Channel *) chan)->state->bottomChanPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *statePtr = chanPtr->state;
- Tcl_DriverThreadActionProc *threadActionProc;
if (statePtr->nextCSPtr != NULL) {
Tcl_Panic("SpliceChannel: trying to add channel used in different list");
@@ -2875,13 +2950,8 @@ Tcl_SpliceChannel(
* For all transformations and the base channel.
*/
- while (chanPtr) {
- threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
- if (threadActionProc != NULL) {
- (*threadActionProc)(chanPtr->instanceData,
- TCL_CHANNEL_THREAD_INSERT);
- }
- chanPtr= chanPtr->upChanPtr;
+ for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
+ ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT);
}
}
@@ -2948,7 +3018,7 @@ Tcl_Close(
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
- if (statePtr->flags & CHANNEL_INCLOSE) {
+ if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_AppendResult(interp, "Illegal recursive call to close "
"through close-handler of channel", NULL);
@@ -2979,7 +3049,7 @@ Tcl_Close(
if (statePtr->chanMsg != NULL) {
if (interp != NULL) {
- Tcl_SetChannelErrorInterp(interp,statePtr->chanMsg);
+ Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg);
}
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
@@ -2995,8 +3065,8 @@ Tcl_Close(
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
- (cbPtr->proc)(cbPtr->clientData);
- ckfree((char *) cbPtr);
+ cbPtr->proc(cbPtr->clientData);
+ ckfree(cbPtr);
}
ResetFlag(statePtr, CHANNEL_INCLOSE);
@@ -3015,7 +3085,7 @@ Tcl_Close(
*/
if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
- result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
+ result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp,
TCL_CLOSE_READ);
} else {
result = 0;
@@ -3065,6 +3135,352 @@ Tcl_Close(
/*
*----------------------------------------------------------------------
*
+ * Tcl_CloseEx --
+ *
+ * Closes one side of a channel, read or write.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Closes one direction of the channel.
+ *
+ * NOTE:
+ * Tcl_CloseEx closes the specified direction of the channel as far as
+ * the user is concerned. The channel keeps existing however. You cannot
+ * calls this function to close the last possible direction of the
+ * channel. Use Tcl_Close for that.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_CloseEx(
+ Tcl_Interp *interp, /* Interpreter for errors. */
+ Tcl_Channel chan, /* The channel being closed. May still be used
+ * by some interpreter. */
+ int flags) /* Flags telling us which side to close. */
+{
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of real IO channel. */
+
+ if (chan == NULL) {
+ return TCL_OK;
+ }
+
+ /* TODO: assert flags validity ? */
+
+ chanPtr = (Channel *) chan;
+ statePtr = chanPtr->state;
+
+ /*
+ * Does the channel support half-close anyway? Error if not.
+ */
+
+ if (!chanPtr->typePtr->close2Proc) {
+ Tcl_AppendResult(interp, "Half-close of channels not supported by ",
+ chanPtr->typePtr->typeName, "s", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Is the channel unstacked ? If not we fail.
+ */
+
+ if (chanPtr != statePtr->topChanPtr) {
+ Tcl_AppendResult(interp,
+ "Half-close not applicable to stack of transformations",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check direction against channel mode. It is an error if we try to close
+ * a direction not supported by the channel (already closed, or never
+ * opened for that direction).
+ */
+
+ if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) {
+ const char *msg;
+
+ if (flags & TCL_CLOSE_READ) {
+ msg = "read";
+ } else {
+ msg = "write";
+ }
+ Tcl_AppendResult(interp, "Half-close of ", msg,
+ "-side not possible, side not opened or already closed",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * A user may try to call half-close from within a channel close
+ * handler. That won't do.
+ */
+
+ if (statePtr->flags & CHANNEL_INCLOSE) {
+ if (interp) {
+ Tcl_AppendResult(interp, "Illegal recursive call to close "
+ "through close-handler of channel", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (flags & TCL_CLOSE_READ) {
+ /*
+ * Call the finalization code directly. There are no events to handle,
+ * there cannot be for the read-side.
+ */
+
+ return CloseChannelPart(interp, chanPtr, 0, flags);
+ } else if (flags & TCL_CLOSE_WRITE) {
+ if ((statePtr->curOutPtr != NULL) &&
+ IsBufferReady(statePtr->curOutPtr)) {
+ SetFlag(statePtr, BUFFER_READY);
+ }
+ Tcl_Preserve(statePtr);
+ if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
+ /*
+ * We don't want to re-enter CloseWrite().
+ */
+
+ if (!GotFlag(statePtr, CHANNEL_CLOSEDWRITE)) {
+ if (CloseWrite(interp, chanPtr) != TCL_OK) {
+ SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+ Tcl_Release(statePtr);
+ return TCL_ERROR;
+ }
+ }
+ }
+ SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+ Tcl_Release(statePtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CloseWrite --
+ *
+ * Closes the write side a channel.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Closes the write side of the channel.
+ *
+ * NOTE:
+ * CloseWrite removes the channel as far as the user is concerned.
+ * However, the ooutput data structures may continue to exist for a while
+ * longer if it has a background flush scheduled. The device itself is
+ * eventually closed and the channel structures modified, in
+ * CloseChannelPart, below.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CloseWrite(
+ Tcl_Interp *interp, /* Interpreter for errors. */
+ Channel *chanPtr) /* The channel whose write side is being
+ * closed. May still be used by some
+ * interpreter */
+{
+ /* Notes: clear-channel-handlers - write side only ? or keep around, just
+ * not called. */
+ /* No close cllbacks are run - channel is still open (read side) */
+
+ ChannelState *statePtr = chanPtr->state;
+ /* State of real IO channel. */
+ int flushcode;
+ int result = 0;
+
+ /*
+ * Ensure that the last output buffer will be flushed.
+ */
+
+ if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
+ SetFlag(statePtr, BUFFER_READY);
+ }
+
+ /*
+ * The call to FlushChannel will flush any queued output and invoke the
+ * close function of the channel driver, or it will set up the channel to
+ * be flushed and closed asynchronously.
+ */
+
+ SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+
+ flushcode = FlushChannel(interp, chanPtr, 0);
+
+ /*
+ * TIP #219.
+ * Capture error messages put by the driver into the bypass area and put
+ * them into the regular interpreter result.
+ *
+ * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags
+ * FlushChannel() has called CloseChannelPart(). While we can still access
+ * "chan" (no structures were freed), the only place which may still
+ * contain a message is the interpreter itself, and "CloseChannelPart" made
+ * sure to lift any channel message it generated into it. Hence the NULL
+ * argument in the call below.
+ */
+
+ if (TclChanCaughtErrorBypass(interp, NULL)) {
+ result = EINVAL;
+ }
+
+ if ((flushcode != 0) || (result != 0)) {
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CloseChannelPart --
+ *
+ * Utility procedure to close a channel partially and free associated
+ * resources. If the channel was stacked it will never be run (The higher
+ * level forbid this). If the channel was not stacked, then we will free
+ * all the bits of the chosen side (read, or write) for the TOP channel.
+ *
+ * Results:
+ * Error code from an unreported error or the driver close2 operation.
+ *
+ * Side effects:
+ * May free memory, may change the value of errno.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CloseChannelPart(
+ Tcl_Interp *interp, /* Interpreter for errors. */
+ Channel *chanPtr, /* The channel being closed. May still be used
+ * by some interpreter. */
+ int errorCode, /* Status of operation so far. */
+ int flags) /* Flags telling us which side to close. */
+{
+ ChannelState *statePtr; /* State of real IO channel. */
+ int result; /* Of calling the close2proc. */
+
+ statePtr = chanPtr->state;
+
+ if (flags & TCL_CLOSE_READ) {
+ /*
+ * No more input can be consumed so discard any leftover input.
+ */
+
+ DiscardInputQueued(statePtr, 1);
+ } else if (flags & TCL_CLOSE_WRITE) {
+ /*
+ * The caller guarantees that there are no more buffers queued for
+ * output.
+ */
+
+ if (statePtr->outQueueHead != NULL) {
+ Tcl_Panic("ClosechanHalf, closed write-side of channel: "
+ "queued output left");
+ }
+
+ /*
+ * If the EOF character is set in the channel, append that to the
+ * output device.
+ */
+
+ if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) {
+ int dummy;
+ char c = (char) statePtr->outEofChar;
+
+ (void) ChanWrite(chanPtr, &c, 1, &dummy);
+ }
+
+ /*
+ * TIP #219, Tcl Channel Reflection API.
+ * Move a leftover error message in the channel bypass into the
+ * interpreter bypass. Just clear it if there is no interpreter.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ if (interp != NULL) {
+ Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg);
+ }
+ TclDecrRefCount(statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
+ }
+
+ /*
+ * Finally do what is asked of us. Close and free the channel driver state
+ * for the chosen side of the channel. This may leave a TIP #219 error
+ * message in the interp.
+ */
+
+ result = ChanCloseHalf(chanPtr, interp, flags);
+
+ /*
+ * If we are being called synchronously, report either any latent error on
+ * the channel or the current error.
+ */
+
+ if (statePtr->unreportedError != 0) {
+ errorCode = statePtr->unreportedError;
+
+ /*
+ * TIP #219, Tcl Channel Reflection API.
+ * Move an error message found in the unreported area into the regular
+ * bypass (interp). This kills any message in the channel bypass area.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ TclDecrRefCount(statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
+ if (interp) {
+ Tcl_SetChannelErrorInterp(interp, statePtr->unreportedMsg);
+ }
+ }
+ if (errorCode == 0) {
+ errorCode = result;
+ if (errorCode != 0) {
+ Tcl_SetErrno(errorCode);
+ }
+ }
+
+ /*
+ * TIP #219.
+ * Capture error messages put by the driver into the bypass area and put
+ * them into the regular interpreter result. See also the bottom of
+ * CloseWrite().
+ */
+
+ if (TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
+ result = EINVAL;
+ }
+
+ if (result != 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remove the closed side from the channel mode/flags.
+ */
+
+ ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ClearChannelHandlers --
*
* Removes all channel handlers and event scripts from the channel,
@@ -3124,7 +3540,7 @@ Tcl_ClearChannelHandlers(
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) {
chNext = chPtr->nextPtr;
- ckfree((char *) chPtr);
+ ckfree(chPtr);
}
statePtr->chPtr = NULL;
@@ -3151,7 +3567,7 @@ Tcl_ClearChannelHandlers(
for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
TclDecrRefCount(ePtr->scriptPtr);
- ckfree((char *) ePtr);
+ ckfree(ePtr);
}
statePtr->scriptRecordPtr = NULL;
}
@@ -3256,9 +3672,7 @@ Tcl_WriteRaw(
* The code was stolen from 'FlushChannel'.
*/
- written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
- src, srcLen, &errorCode);
-
+ written = ChanWrite(chanPtr, src, srcLen, &errorCode);
if (written < 0) {
Tcl_SetErrno(errorCode);
}
@@ -3359,12 +3773,13 @@ DoWriteChars(
* be extended to more efficient translation of the src string.
*/
- int result;
+ int result;
if ((len == 1) && (UCHAR(*src) < 0xC0)) {
result = WriteBytes(chanPtr, src, len);
} else {
Tcl_Obj *objPtr = Tcl_NewStringObj(src, len);
+
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
result = WriteBytes(chanPtr, src, len);
TclDecrRefCount(objPtr);
@@ -3410,7 +3825,7 @@ Tcl_WriteObj(
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
- char *src;
+ const char *src;
int srcLen;
statePtr = ((Channel *) chan)->state;
@@ -3428,6 +3843,38 @@ Tcl_WriteObj(
}
}
+static void
+WillWrite(
+ Channel *chanPtr)
+{
+ int inputBuffered;
+
+ if ((chanPtr->typePtr->seekProc != NULL) &&
+ ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
+ int ignore;
+
+ DiscardInputQueued(chanPtr->state, 0);
+ ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore);
+ }
+}
+
+static int
+WillRead(
+ Channel *chanPtr)
+{
+ if ((chanPtr->typePtr->seekProc != NULL)
+ && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
+ if ((chanPtr->state->curOutPtr != NULL)
+ && IsBufferReady(chanPtr->state->curOutPtr)) {
+ SetFlag(chanPtr->state, BUFFER_READY);
+ }
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ }
+ return 0;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -3461,11 +3908,15 @@ WriteBytes(
char *dst;
int dstMax, sawLF, savedLF, total, dstLen, toWrite, translate;
+ if (srcLen) {
+ WillWrite(chanPtr);
+ }
+
total = 0;
sawLF = 0;
savedLF = 0;
- translate = (statePtr->flags & CHANNEL_LINEBUFFERED)
- || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
+ translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED)
+ || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
/*
* Loop over all bytes in src, storing them in output buffer with proper
@@ -3562,6 +4013,10 @@ WriteChars(
Tcl_Encoding encoding;
char safe[BUFFER_PADDING];
+ if (srcLen) {
+ WillWrite(chanPtr);
+ }
+
total = 0;
sawLF = 0;
savedLF = 0;
@@ -3574,8 +4029,8 @@ WriteChars(
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
- translate = (statePtr->flags & CHANNEL_LINEBUFFERED)
- || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
+ translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED)
+ || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
/*
* Loop over all UTF-8 characters in src, storing them in staging buffer
@@ -3598,16 +4053,17 @@ WriteChars(
if (savedLF) {
/*
* A '\n' was left over from last call to TranslateOutputEOL()
- * and we need to store it in the staging buffer. If the channel
- * is line-based, we will need to flush the output buffer (after
- * translating the staging buffer).
+ * and we need to store it in the staging buffer. If the
+ * channel is line-based, we will need to flush the output
+ * buffer (after translating the staging buffer).
*/
*stage++ = '\n';
stageLen--;
sawLF++;
}
- if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) {
+ if (TranslateOutputEOL(statePtr, stage, src, &stageLen,
+ &toWrite)) {
sawLF++;
}
@@ -3900,18 +4356,18 @@ CheckFlush(
* 3. if it contains any output and this channel is unbuffered.
*/
- if ((statePtr->flags & BUFFER_READY) == 0) {
+ if (!GotFlag(statePtr, BUFFER_READY)) {
if (IsBufferFull(bufPtr)) {
SetFlag(statePtr, BUFFER_READY);
- } else if (statePtr->flags & CHANNEL_LINEBUFFERED) {
+ } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) {
if (newlineFlag != 0) {
SetFlag(statePtr, BUFFER_READY);
}
- } else if (statePtr->flags & CHANNEL_UNBUFFERED) {
+ } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) {
SetFlag(statePtr, BUFFER_READY);
}
}
- if (statePtr->flags & BUFFER_READY) {
+ if (GotFlag(statePtr, BUFFER_READY)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
@@ -3948,7 +4404,7 @@ Tcl_Gets(
{
Tcl_Obj *objPtr;
int charsStored, length;
- char *string;
+ const char *string;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
@@ -4162,7 +4618,7 @@ Tcl_GetsObj(
case TCL_TRANSLATE_AUTO:
eol = dst;
skip = 1;
- if (statePtr->flags & INPUT_SAW_CR) {
+ if (GotFlag(statePtr, INPUT_SAW_CR)) {
ResetFlag(statePtr, INPUT_SAW_CR);
if ((eol < dstEnd) && (*eol == '\n')) {
/*
@@ -4230,7 +4686,7 @@ Tcl_GetsObj(
SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
skip = 0;
eol = dstEnd;
if (eol == objPtr->bytes + oldLength) {
@@ -4258,6 +4714,13 @@ Tcl_GetsObj(
*/
gotEOL:
+ /*
+ * Regenerate the top channel, in case it was changed due to
+ * self-modifying reflected transforms.
+ */
+
+ chanPtr = statePtr->topChanPtr;
+
bufPtr = gs.bufPtr;
if (bufPtr == NULL) {
Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL");
@@ -4286,6 +4749,13 @@ Tcl_GetsObj(
*/
restore:
+ /*
+ * Regenerate the top channel, in case it was changed due to
+ * self-modifying reflected transforms.
+ */
+
+ chanPtr = statePtr->topChanPtr;
+
bufPtr = statePtr->inQueueHead;
if (bufPtr == NULL) {
Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");
@@ -4321,6 +4791,13 @@ Tcl_GetsObj(
*/
done:
+ /*
+ * Regenerate the top channel, in case it was changed due to
+ * self-modifying reflected transforms.
+ */
+
+ chanPtr = statePtr->topChanPtr;
+
UpdateInterest(chanPtr);
return copiedTotal;
}
@@ -4387,7 +4864,11 @@ TclGetsObjBinary(
skip = 0;
eof = NULL;
inEofChar = statePtr->inEofChar;
- /* Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR */
+
+ /*
+ * Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR.
+ */
+
eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r';
while (1) {
@@ -4410,8 +4891,8 @@ TclGetsObjBinary(
* device. Side effect is to allocate another channel buffer.
*/
- if (statePtr->flags & CHANNEL_BLOCKED) {
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
goto restore;
}
ResetFlag(statePtr, CHANNEL_BLOCKED);
@@ -4462,7 +4943,7 @@ TclGetsObjBinary(
SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
skip = 0;
eol = dstEnd;
if ((dst == dstEnd) && (byteLen == oldLength)) {
@@ -4661,8 +5142,8 @@ FilterInputBytes(
*/
read:
- if (statePtr->flags & CHANNEL_BLOCKED) {
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
gsPtr->charsWrote = 0;
gsPtr->rawRead = 0;
return -1;
@@ -4742,7 +5223,7 @@ FilterInputBytes(
* returning those UTF-8 characters because a EOL might be
* present in them.
*/
- } else if (statePtr->flags & CHANNEL_EOF) {
+ } else if (GotFlag(statePtr, CHANNEL_EOF)) {
/*
* There was a partial character followed by EOF on the
* device. Fall through, returning that nothing was found.
@@ -4764,7 +5245,7 @@ FilterInputBytes(
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
- memcpy(nextPtr->buf + BUFFER_PADDING - extra,
+ memcpy(nextPtr->buf + (BUFFER_PADDING - extra),
raw + gsPtr->rawRead, (size_t) extra);
nextPtr->nextRemoved -= extra;
bufPtr->nextAdded -= extra;
@@ -4831,7 +5312,7 @@ PeekAhead(
goto cleanup;
}
- if ((statePtr->flags & CHANNEL_NONBLOCKING) == 0) {
+ if (!GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
if (blockModeProc == NULL) {
/*
@@ -4913,7 +5394,7 @@ CommonGetsCleanup(
extra = SpaceLeft(bufPtr);
if (extra > 0) {
memcpy(InsertPoint(bufPtr),
- nextPtr->buf + BUFFER_PADDING - extra,
+ nextPtr->buf + (BUFFER_PADDING - extra),
(size_t) extra);
bufPtr->nextAdded += extra;
nextPtr->nextRemoved = BUFFER_PADDING;
@@ -5027,11 +5508,11 @@ Tcl_ReadRaw(
copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
bytesToRead - copied);
if (copiedNow == 0) {
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
goto done;
}
- if (statePtr->flags & CHANNEL_BLOCKED) {
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
goto done;
}
ResetFlag(statePtr, CHANNEL_BLOCKED);
@@ -5045,9 +5526,9 @@ Tcl_ReadRaw(
* and only if we are sure to have data.
*/
- if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
- !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
+ !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) {
/*
* We bypass the driver; it would block as no data is
* available.
@@ -5055,9 +5536,9 @@ Tcl_ReadRaw(
nread = -1;
result = EWOULDBLOCK;
- } else {
+ } else
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
-
+ {
/*
* Now go to the driver to get as much as is possible to fill
* the remaining request. Do all the error handling by
@@ -5067,12 +5548,9 @@ Tcl_ReadRaw(
* The case of 'bytesToRead == 0' at this point cannot happen.
*/
- nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
- bufPtr + copied, bytesToRead - copied, &result);
-
-#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
+ nread = ChanRead(chanPtr, bufPtr + copied,
+ bytesToRead - copied, &result);
}
-#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
/*
@@ -5096,7 +5574,6 @@ Tcl_ReadRaw(
ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
-
} else if (nread == 0) {
SetFlag(statePtr, CHANNEL_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
@@ -5272,9 +5749,8 @@ DoReadChars(
bufPtr = statePtr->inQueueHead;
if (IsBufferEmpty(bufPtr)) {
- ChannelBuffer *nextPtr;
+ ChannelBuffer *nextPtr = bufPtr->nextPtr;
- nextPtr = bufPtr->nextPtr;
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
if (nextPtr == NULL) {
@@ -5284,11 +5760,11 @@ DoReadChars(
}
if (copiedNow < 0) {
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
}
- if (statePtr->flags & CHANNEL_BLOCKED) {
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
break;
}
ResetFlag(statePtr, CHANNEL_BLOCKED);
@@ -5320,6 +5796,13 @@ DoReadChars(
*/
done:
+ /*
+ * Regenerate the top channel, in case it was changed due to
+ * self-modifying reflected transforms.
+ */
+
+ chanPtr = statePtr->topChanPtr;
+
UpdateInterest(chanPtr);
return copied;
}
@@ -5400,7 +5883,7 @@ ReadBytes(
}
dst += offset;
- if (statePtr->flags & INPUT_NEED_NL) {
+ if (GotFlag(statePtr, INPUT_NEED_NL)) {
ResetFlag(statePtr, INPUT_NEED_NL);
if ((srcLen == 0) || (*src != '\n')) {
*dst = '\r';
@@ -5492,7 +5975,7 @@ ReadChars(
srcLen = BytesLeft(bufPtr);
toRead = charsToRead;
- if ((unsigned)toRead > (unsigned)srcLen) {
+ if ((unsigned) toRead > (unsigned) srcLen) {
toRead = srcLen;
}
@@ -5581,7 +6064,7 @@ ReadChars(
}
oldState = statePtr->inputEncodingState;
- if (statePtr->flags & INPUT_NEED_NL) {
+ if (GotFlag(statePtr, INPUT_NEED_NL)) {
/*
* We want a '\n' because the last character we saw was '\r'.
*/
@@ -5697,16 +6180,15 @@ ReadChars(
* '\n' in dst.
*/
- numChars -= (dstRead - dstWrote);
+ numChars -= dstRead - dstWrote;
if ((unsigned) numChars > (unsigned) toRead) {
/*
* Got too many chars.
*/
- const char *eof;
+ const char *eof = Tcl_UtfAtIndex(dst, toRead);
- eof = Tcl_UtfAtIndex(dst, toRead);
statePtr->inputEncodingState = oldState;
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
@@ -5774,9 +6256,8 @@ TranslateInputEOL(
* buffer.
*/
- const char *src, *srcMax;
+ const char *src, *srcMax = srcStart + *srcLenPtr;
- srcMax = srcStart + *srcLenPtr;
for (src = srcStart; src < srcMax; src++) {
if (*src == inEofChar) {
eof = src;
@@ -5847,7 +6328,7 @@ TranslateInputEOL(
srcEnd = srcStart + dstLen;
srcMax = srcStart + *srcLenPtr;
- if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) {
+ if (GotFlag(statePtr, INPUT_SAW_CR) && (src < srcMax)) {
if (*src == '\n') {
src++;
}
@@ -5952,7 +6433,7 @@ Tcl_Ungets(
* bit. We want to discover these conditions anew in each operation.
*/
- if (statePtr->flags & CHANNEL_STICKY_EOF) {
+ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
goto done;
}
ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_EOF);
@@ -6078,7 +6559,7 @@ DiscardInputQueued(
*/
if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
- ckfree((char *) statePtr->saveInBufPtr);
+ ckfree(statePtr->saveInBufPtr);
statePtr->saveInBufPtr = NULL;
}
}
@@ -6171,7 +6652,7 @@ GetInput(
if ((bufPtr != NULL)
&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
- ckfree((char *) bufPtr);
+ ckfree(bufPtr);
bufPtr = NULL;
}
@@ -6209,36 +6690,32 @@ GetInput(
* platforms it is impossible to read from a device after EOF.
*/
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
return 0;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/*
- * [SF Tcl Bug 943274]. Better emulation of non-blocking channels for
- * channels without BlockModeProc, by keeping track of true fileevents
- * generated by the OS == Data waiting and reading if and only if we are
- * sure to have data.
+ * [Bug 943274]: Better emulation of non-blocking channels for channels
+ * without BlockModeProc, by keeping track of true fileevents generated by
+ * the OS == Data waiting and reading if and only if we are sure to have
+ * data.
*/
- if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
- !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
+ !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) {
/*
* Bypass the driver, it would block, as no data is available
*/
nread = -1;
result = EWOULDBLOCK;
- } else {
+ } else
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
-
- nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
- InsertPoint(bufPtr), toRead, &result);
-
-#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
+ {
+ nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result);
}
-#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
bufPtr->nextAdded += nread;
@@ -6257,14 +6734,12 @@ GetInput(
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (nread <= toRead) {
/*
- * [SF Tcl Bug 943274] We have read the available data, clear
- * flag.
+ * [Bug 943274]: We have read the available data, clear flag.
*/
ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
-
} else if (nread == 0) {
SetFlag(statePtr, CHANNEL_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
@@ -6380,8 +6855,8 @@ Tcl_Seek(
* point. Also clear CR related flags.
*/
- statePtr->flags &=
- ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR);
+ ResetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED |
+ INPUT_SAW_CR);
/*
* If the channel is in asynchronous output mode, switch it back to
@@ -6391,14 +6866,14 @@ Tcl_Seek(
*/
wasAsync = 0;
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
return Tcl_LongAsWide(-1);
}
ResetFlag(statePtr, CHANNEL_NONBLOCKING);
- if (statePtr->flags & BG_FLUSH_SCHEDULED) {
+ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
}
}
@@ -6425,23 +6900,10 @@ Tcl_Seek(
} else {
/*
* Now seek to the new position in the channel as requested by the
- * caller. Note that we prefer the wideSeekProc if that is available
- * and non-NULL...
+ * caller.
*/
- if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
- chanPtr->typePtr->wideSeekProc != NULL) {
- curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
- offset, mode, &result);
- } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
- offset > Tcl_LongAsWide(LONG_MAX)) {
- result = EOVERFLOW;
- curPos = Tcl_LongAsWide(-1);
- } else {
- curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
- chanPtr->instanceData, Tcl_WideAsLong(offset), mode,
- &result));
- }
+ curPos = ChanSeek(chanPtr, offset, mode, &result);
if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
}
@@ -6536,29 +6998,18 @@ Tcl_Tell(
inputBuffered = Tcl_InputBuffered(chan);
outputBuffered = Tcl_OutputBuffered(chan);
- if ((inputBuffered != 0) && (outputBuffered != 0)) {
- Tcl_SetErrno(EFAULT);
- return Tcl_LongAsWide(-1);
- }
-
/*
* Get the current position in the device and compute the position where
* the next character will be read or written. Note that we prefer the
* wideSeekProc if that is available and non-NULL...
*/
- if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
- chanPtr->typePtr->wideSeekProc != NULL) {
- curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
- Tcl_LongAsWide(0), SEEK_CUR, &result);
- } else {
- curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
- chanPtr->instanceData, 0, SEEK_CUR, &result));
- }
+ curPos = ChanSeek(chanPtr, Tcl_LongAsWide(0), SEEK_CUR, &result);
if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
return Tcl_LongAsWide(-1);
}
+
if (inputBuffered != 0) {
return curPos - inputBuffered;
}
@@ -6592,19 +7043,18 @@ Tcl_SeekOld(
{
Tcl_WideInt wOffset, wResult;
- wOffset = Tcl_LongAsWide((long)offset);
+ wOffset = Tcl_LongAsWide((long) offset);
wResult = Tcl_Seek(chan, wOffset, mode);
- return (int)Tcl_WideAsLong(wResult);
+ return (int) Tcl_WideAsLong(wResult);
}
int
Tcl_TellOld(
Tcl_Channel chan) /* The channel to return pos for. */
{
- Tcl_WideInt wResult;
+ Tcl_WideInt wResult = Tcl_Tell(chan);
- wResult = Tcl_Tell(chan);
- return (int)Tcl_WideAsLong(wResult);
+ return (int) Tcl_WideAsLong(wResult);
}
/*
@@ -6645,7 +7095,7 @@ Tcl_TruncateChannel(
return TCL_ERROR;
}
- if (!(chanPtr->state->flags & TCL_WRITABLE)) {
+ if (!GotFlag(chanPtr->state, TCL_WRITABLE)) {
/*
* We require that the file was opened of writing. Do that check now
* so that we only flush if we think we're going to succeed.
@@ -6660,8 +7110,10 @@ Tcl_TruncateChannel(
* pre-read input data.
*/
- if (Tcl_Seek(chan, (Tcl_WideInt)0, SEEK_CUR) == Tcl_LongAsWide(-1)) {
- return TCL_ERROR;
+ WillWrite(chanPtr);
+
+ if (WillRead(chanPtr) < 0) {
+ return TCL_ERROR;
}
/*
@@ -6731,8 +7183,7 @@ CheckChannelErrors(
* order to drain data from stacked channels.
*/
- if ((statePtr->flags & CHANNEL_CLOSED) &&
- ((flags & CHANNEL_RAW_MODE) == 0)) {
+ if (GotFlag(statePtr, CHANNEL_CLOSED) && !(flags & CHANNEL_RAW_MODE)) {
Tcl_SetErrno(EACCES);
return -1;
}
@@ -6754,7 +7205,7 @@ CheckChannelErrors(
* retrieving and transforming the data to copy.
*/
- if (BUSY_STATE(statePtr,flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
+ if (BUSY_STATE(statePtr, flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
Tcl_SetErrno(EBUSY);
return -1;
}
@@ -6767,7 +7218,7 @@ CheckChannelErrors(
* discover these conditions anew in each operation.
*/
- if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) {
+ if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
ResetFlag(statePtr, CHANNEL_EOF);
}
ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
@@ -6799,8 +7250,8 @@ Tcl_Eof(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
- return ((statePtr->flags & CHANNEL_STICKY_EOF) ||
- ((statePtr->flags & CHANNEL_EOF) &&
+ return (GotFlag(statePtr, CHANNEL_STICKY_EOF) ||
+ (GotFlag(statePtr, CHANNEL_EOF) &&
(Tcl_InputBuffered(chan) == 0))) ? 1 : 0;
}
@@ -6827,7 +7278,7 @@ Tcl_InputBlocked(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
- return (statePtr->flags & CHANNEL_BLOCKED) ? 1 : 0;
+ return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0;
}
/*
@@ -6980,21 +7431,20 @@ Tcl_SetChannelBufferSize(
*/
if (sz < 1) {
- sz = 1;
+ sz = 1;
} else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
- sz = MAX_CHANNEL_BUFFER_SIZE;
+ sz = MAX_CHANNEL_BUFFER_SIZE;
}
statePtr = ((Channel *) chan)->state;
statePtr->bufSize = sz;
if (statePtr->outputStage != NULL) {
- ckfree((char *) statePtr->outputStage);
+ ckfree(statePtr->outputStage);
statePtr->outputStage = NULL;
}
- if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
- statePtr->outputStage = (char *)
- ckalloc((unsigned) (statePtr->bufSize + 2));
+ if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
+ statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
}
}
@@ -7088,7 +7538,7 @@ Tcl_BadChannelOption(
}
Tcl_AppendResult(interp, "or -", argv[i], NULL);
Tcl_DStringFree(&ds);
- ckfree((char *) argv);
+ ckfree(argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
@@ -7150,9 +7600,9 @@ Tcl_GetChannelOption(
*/
if (statePtr->csPtrR) {
- flags = statePtr->csPtrR->readFlags;
+ flags = statePtr->csPtrR->readFlags;
} else if (statePtr->csPtrW) {
- flags = statePtr->csPtrW->writeFlags;
+ flags = statePtr->csPtrW->writeFlags;
} else {
flags = statePtr->flags;
}
@@ -7312,8 +7762,8 @@ Tcl_GetChannelOption(
* and message.
*/
- return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData,
- interp, optionName, dsPtr);
+ return chanPtr->typePtr->getOptionProc(chanPtr->instanceData, interp,
+ optionName, dsPtr);
} else {
/*
* No driver specific options case.
@@ -7404,8 +7854,7 @@ Tcl_SetChannelOption(
} else if (HaveOpt(7, "-buffering")) {
len = strlen(newValue);
if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) {
- statePtr->flags &=
- ~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED);
+ ResetFlag(statePtr, CHANNEL_UNBUFFERED | CHANNEL_LINEBUFFERED);
} else if ((newValue[0] == 'l') &&
(strncmp(newValue, "line", len) == 0)) {
ResetFlag(statePtr, CHANNEL_UNBUFFERED);
@@ -7414,12 +7863,10 @@ Tcl_SetChannelOption(
(strncmp(newValue, "none", len) == 0)) {
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
- } else {
- if (interp) {
- Tcl_AppendResult(interp, "bad value for -buffering: "
- "must be one of full, line, or none", NULL);
- return TCL_ERROR;
- }
+ } else if (interp) {
+ Tcl_AppendResult(interp, "bad value for -buffering: "
+ "must be one of full, line, or none", NULL);
+ return TCL_ERROR;
}
return TCL_OK;
} else if (HaveOpt(7, "-buffersize")) {
@@ -7470,18 +7917,19 @@ Tcl_SetChannelOption(
int outIndex = (argc - 1);
int inValue = (int) argv[0][0];
int outValue = (int) argv[outIndex][0];
+
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_AppendResult(interp, "bad value for -eofchar: ",
"must be non-NUL ASCII character", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
- if (statePtr->flags & TCL_READABLE) {
+ if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = inValue;
}
- if (statePtr->flags & TCL_WRITABLE) {
+ if (GotFlag(statePtr, TCL_WRITABLE)) {
statePtr->outEofChar = outValue;
}
} else {
@@ -7490,11 +7938,11 @@ Tcl_SetChannelOption(
"bad value for -eofchar: should be a list of zero,"
" one, or two elements", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
if (argv != NULL) {
- ckfree((char *) argv);
+ ckfree(argv);
}
/*
@@ -7503,9 +7951,7 @@ Tcl_SetChannelOption(
* ahead'. Ditto for blocked.
*/
- statePtr->flags &=
- ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED);
-
+ ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED);
return TCL_OK;
} else if (HaveOpt(1, "-translation")) {
const char *readMode, *writeMode;
@@ -7515,23 +7961,24 @@ Tcl_SetChannelOption(
}
if (argc == 1) {
- readMode = (statePtr->flags & TCL_READABLE) ? argv[0] : NULL;
- writeMode = (statePtr->flags & TCL_WRITABLE) ? argv[0] : NULL;
+ readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
+ writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[0] : NULL;
} else if (argc == 2) {
- readMode = (statePtr->flags & TCL_READABLE) ? argv[0] : NULL;
- writeMode = (statePtr->flags & TCL_WRITABLE) ? argv[1] : NULL;
+ readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
+ writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -translation: must be a one or two"
" element list", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
if (readMode) {
TclEolTranslation translation;
+
if (*readMode == '\0') {
translation = statePtr->inputTranslation;
} else if (strcmp(readMode, "auto") == 0) {
@@ -7556,7 +8003,7 @@ Tcl_SetChannelOption(
"must be one of auto, binary, cr, lf, crlf,"
" or platform", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
@@ -7607,15 +8054,15 @@ Tcl_SetChannelOption(
"must be one of auto, binary, cr, lf, crlf,"
" or platform", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_OK;
} else if (chanPtr->typePtr->setOptionProc != NULL) {
- return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
- interp, optionName, newValue);
+ return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
+ optionName, newValue);
} else {
return Tcl_BadChannelOption(interp, optionName, NULL);
}
@@ -7644,8 +8091,8 @@ Tcl_SetChannelOption(
ckfree(statePtr->outputStage);
statePtr->outputStage = NULL;
}
- if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2));
+ if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
+ statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
}
return TCL_OK;
}
@@ -7697,7 +8144,7 @@ CleanupChannelHandlers(
TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
- ckfree((char *) sPtr);
+ ckfree(sPtr);
} else {
prevPtr = sPtr;
}
@@ -7746,9 +8193,9 @@ Tcl_NotifyChannel(
*/
if ((mask & TCL_READABLE) &&
- (statePtr->flags & CHANNEL_NONBLOCKING) &&
+ GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
- !(statePtr->flags & CHANNEL_TIMER_FEV)) {
+ !GotFlag(statePtr, CHANNEL_TIMER_FEV)) {
SetFlag(statePtr, CHANNEL_HAS_MORE_DATA);
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
@@ -7765,14 +8212,14 @@ Tcl_NotifyChannel(
* their own events and pass them upward.
*/
- while (mask && (chanPtr->upChanPtr != (NULL))) {
+ while (mask && (chanPtr->upChanPtr != NULL)) {
Tcl_DriverHandlerProc *upHandlerProc;
upChanPtr = chanPtr->upChanPtr;
upTypePtr = upChanPtr->typePtr;
upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
if (upHandlerProc != NULL) {
- mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
+ mask = upHandlerProc(upChanPtr->instanceData, mask);
}
/*
@@ -7811,7 +8258,7 @@ Tcl_NotifyChannel(
* don't call any write handlers before the flush is complete.
*/
- if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
+ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
FlushChannel(NULL, chanPtr, 1);
mask &= ~TCL_WRITABLE;
}
@@ -7833,7 +8280,7 @@ Tcl_NotifyChannel(
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
- (*(chPtr->proc))(chPtr->clientData, mask);
+ chPtr->proc(chPtr->clientData, mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
@@ -7886,7 +8333,7 @@ UpdateInterest(
* watch for the channel to become writable.
*/
- if (statePtr->flags & BG_FLUSH_SCHEDULED) {
+ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
mask |= TCL_WRITABLE;
}
@@ -7898,7 +8345,7 @@ UpdateInterest(
*/
if (mask & TCL_READABLE) {
- if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
+ if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
mask &= ~TCL_READABLE;
@@ -7949,7 +8396,7 @@ UpdateInterest(
}
}
}
- (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
+ ChanWatch(chanPtr, mask);
}
/*
@@ -7977,7 +8424,7 @@ ChannelTimerProc(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
- if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
+ if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
@@ -7997,14 +8444,14 @@ ChannelTimerProc(
* similar test is done in "PeekAhead".
*/
- if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
- (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING) &&
+ (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
SetFlag(statePtr, CHANNEL_TIMER_FEV);
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
Tcl_Preserve(statePtr);
- Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
ResetFlag(statePtr, CHANNEL_TIMER_FEV);
@@ -8068,7 +8515,7 @@ Tcl_CreateChannelHandler(
}
}
if (chPtr == NULL) {
- chPtr = (ChannelHandler *) ckalloc(sizeof(ChannelHandler));
+ chPtr = ckalloc(sizeof(ChannelHandler));
chPtr->mask = 0;
chPtr->proc = proc;
chPtr->clientData = clientData;
@@ -8172,7 +8619,7 @@ Tcl_DeleteChannelHandler(
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
- ckfree((char *) chPtr);
+ ckfree(chPtr);
/*
* Recompute the interest list for the channel, so that infinite loops
@@ -8223,6 +8670,7 @@ DeleteScriptRecord(
if (esPtr == statePtr->scriptRecordPtr) {
statePtr->scriptRecordPtr = esPtr->nextPtr;
} else {
+ CLANG_ASSERT(prevEsPtr);
prevEsPtr->nextPtr = esPtr->nextPtr;
}
@@ -8230,7 +8678,7 @@ DeleteScriptRecord(
TclChannelEventScriptInvoker, esPtr);
TclDecrRefCount(esPtr->scriptPtr);
- ckfree((char *) esPtr);
+ ckfree(esPtr);
break;
}
@@ -8279,7 +8727,7 @@ CreateScriptRecord(
makeCH = (esPtr == NULL);
if (makeCH) {
- esPtr = (EventScriptRecord *) ckalloc(sizeof(EventScriptRecord));
+ esPtr = ckalloc(sizeof(EventScriptRecord));
}
/*
@@ -8361,7 +8809,7 @@ TclChannelEventScriptInvoker(
if (chanPtr->typePtr != NULL) {
DeleteScriptRecord(interp, chanPtr, mask);
}
- TclBackgroundException(interp, result);
+ Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
}
@@ -8397,10 +8845,10 @@ Tcl_FileEventObjCmd(
Channel *chanPtr; /* The channel to create the handler for. */
ChannelState *statePtr; /* State info for channel */
Tcl_Channel chan; /* The opaque type for the channel. */
- char *chanName;
+ const char *chanName;
int modeIndex; /* Index of mode argument. */
int mask;
- static const char *modeOptions[] = {"readable", "writable", NULL};
+ static const char *const modeOptions[] = {"readable", "writable", NULL};
static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
@@ -8432,6 +8880,7 @@ Tcl_FileEventObjCmd(
if (objc == 3) {
EventScriptRecord *esPtr;
+
for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL;
esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
@@ -8511,13 +8960,25 @@ ZeroTransferTimerProc(
*/
int
-TclCopyChannel(
+TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
int toRead, /* Amount of data to copy, or -1 for all. */
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
+ return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
+ cmdPtr);
+}
+
+int
+TclCopyChannel(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Channel inChan, /* Channel to read from. */
+ Tcl_Channel outChan, /* Channel to write to. */
+ Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */
+ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
+{
Channel *inPtr = (Channel *) inChan;
Channel *outPtr = (Channel *) outChan;
ChannelState *inStatePtr, *outStatePtr;
@@ -8528,14 +8989,14 @@ TclCopyChannel(
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
- if (BUSY_STATE(inStatePtr,TCL_READABLE)) {
+ if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
Tcl_AppendResult(interp, "channel \"",
Tcl_GetChannelName(inChan), "\" is busy", NULL);
}
return TCL_ERROR;
}
- if (BUSY_STATE(outStatePtr,TCL_WRITABLE)) {
+ if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) {
if (interp) {
Tcl_AppendResult(interp, "channel \"",
Tcl_GetChannelName(outChan), "\" is busy", NULL);
@@ -8571,8 +9032,8 @@ TclCopyChannel(
* Make sure the output side is unbuffered.
*/
- outStatePtr->flags = (outStatePtr->flags & ~(CHANNEL_LINEBUFFERED))
- | CHANNEL_UNBUFFERED;
+ outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED)
+ | CHANNEL_UNBUFFERED;
/*
* Allocate a new CopyState to maintain info about the current copy in
@@ -8580,14 +9041,14 @@ TclCopyChannel(
* completed.
*/
- csPtr = (CopyState *) ckalloc(sizeof(CopyState) + inStatePtr->bufSize);
+ csPtr = ckalloc(sizeof(CopyState) + inStatePtr->bufSize);
csPtr->bufSize = inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
- csPtr->total = 0;
+ csPtr->total = (Tcl_WideInt) 0;
csPtr->interp = interp;
if (cmdPtr) {
Tcl_IncrRefCount(cmdPtr);
@@ -8642,7 +9103,7 @@ CopyData(
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK, size, sizeb;
Tcl_WideInt total;
- char *buffer;
+ const char *buffer;
int inBinary, outBinary, sameEncoding;
/* Encoding control */
int underflow; /* Input underflow */
@@ -8671,7 +9132,7 @@ CopyData(
Tcl_IncrRefCount(bufObj);
}
- while (csPtr->toRead != 0) {
+ while (csPtr->toRead != (Tcl_WideInt) 0) {
/*
* Check for unreported background errors.
*/
@@ -8695,24 +9156,25 @@ CopyData(
* underflow instead to prime the readable fileevent.
*/
- size = 0;
+ size = 0;
underflow = 1;
} else {
/*
* Read up to bufSize bytes.
*/
- if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) {
+ if ((csPtr->toRead == (Tcl_WideInt) -1)
+ || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
- sizeb = csPtr->toRead;
+ sizeb = (int) csPtr->toRead;
}
if (inBinary || sameEncoding) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
- 0 /* No append */);
+ 0 /* No append */);
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
@@ -8746,7 +9208,7 @@ CopyData(
break;
}
if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) &&
- !(mask & TCL_READABLE)) {
+ !(mask & TCL_READABLE)) {
if (mask & TCL_WRITABLE) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr);
}
@@ -8811,7 +9273,7 @@ CopyData(
}
/*
- * (UP) Update the current byte count. Do it now so the count is valid
+ * Update the current byte count. Do it now so the count is valid
* before a return or break takes us out of the loop. The invariant at
* the top of the loop should be that csPtr->toRead holds the number
* of bytes left to copy.
@@ -8837,7 +9299,7 @@ CopyData(
* therefore we don't need a writable handler.
*/
- if (!underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED)) {
+ if (!underflow && GotFlag(outStatePtr, BG_FLUSH_SCHEDULED)) {
if (!(mask & TCL_WRITABLE)) {
if (mask & TCL_READABLE) {
Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr);
@@ -8888,6 +9350,7 @@ CopyData(
total = csPtr->total;
if (cmdPtr && interp) {
int code;
+
/*
* Get a private copy of the command so we can mutate it by adding
* arguments. Note that StopCopy frees our saved reference to the
@@ -8905,7 +9368,7 @@ CopyData(
}
code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
- TclBackgroundException(interp, code);
+ Tcl_BackgroundException(interp, code);
result = TCL_ERROR;
}
TclDecrRefCount(cmdPtr);
@@ -8930,9 +9393,8 @@ CopyData(
*
* DoRead --
*
- * Reads a given number of bytes from a channel.
- *
- * No encoding conversions are applied to the bytes being read.
+ * Reads a given number of bytes from a channel. No encoding conversions
+ * are applied to the bytes being read.
*
* Results:
* The number of characters read, or -1 on error. Use Tcl_GetErrno() to
@@ -8964,7 +9426,7 @@ DoRead(
* operation.
*/
- if (!(statePtr->flags & CHANNEL_STICKY_EOF)) {
+ if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
ResetFlag(statePtr, CHANNEL_EOF);
}
ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
@@ -8973,11 +9435,11 @@ DoRead(
copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied,
toRead - copied);
if (copiedNow == 0) {
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
goto done;
}
- if (statePtr->flags & CHANNEL_BLOCKED) {
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
+ if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
goto done;
}
ResetFlag(statePtr, CHANNEL_BLOCKED);
@@ -9131,7 +9593,7 @@ CopyAndTranslateBuffer(
curByte = *src;
if (curByte == '\n') {
ResetFlag(statePtr, INPUT_SAW_CR);
- } else if (statePtr->flags & INPUT_SAW_CR) {
+ } else if (GotFlag(statePtr, INPUT_SAW_CR)) {
ResetFlag(statePtr, INPUT_SAW_CR);
*dst = '\r';
dst++;
@@ -9174,7 +9636,7 @@ CopyAndTranslateBuffer(
*dst = '\n';
dst++;
} else {
- if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) {
+ if ((curByte != '\n') || !GotFlag(statePtr, INPUT_SAW_CR)) {
*dst = (char) curByte;
dst++;
}
@@ -9443,10 +9905,10 @@ DoWrite(
*/
outBufPtr->nextAdded += destCopied;
- if (!(statePtr->flags & BUFFER_READY)) {
+ if (!GotFlag(statePtr, BUFFER_READY)) {
if (IsBufferFull(outBufPtr)) {
SetFlag(statePtr, BUFFER_READY);
- } else if (statePtr->flags & CHANNEL_LINEBUFFERED) {
+ } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) {
for (sPtr = src, i = 0, foundNewline = 0;
(i < srcCopied) && (!foundNewline);
i++, sPtr++) {
@@ -9458,7 +9920,7 @@ DoWrite(
if (foundNewline) {
SetFlag(statePtr, BUFFER_READY);
}
- } else if (statePtr->flags & CHANNEL_UNBUFFERED) {
+ } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) {
SetFlag(statePtr, BUFFER_READY);
}
}
@@ -9467,7 +9929,7 @@ DoWrite(
src += srcCopied;
srcLen -= srcCopied;
- if (statePtr->flags & BUFFER_READY) {
+ if (GotFlag(statePtr, BUFFER_READY)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
@@ -9500,7 +9962,7 @@ CopyEventProc(
ClientData clientData,
int mask)
{
- (void) CopyData((CopyState *) clientData, mask);
+ (void) CopyData(clientData, mask);
}
/*
@@ -9538,19 +10000,19 @@ StopCopy(
* Restore the old blocking mode and output buffering mode.
*/
- nonBlocking = (csPtr->readFlags & CHANNEL_NONBLOCKING);
+ nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING;
if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->readPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
if (csPtr->readPtr != csPtr->writePtr) {
- nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING);
+ nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING;
if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->writePtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
}
- outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
+ ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
outStatePtr->flags |=
csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
@@ -9565,7 +10027,7 @@ StopCopy(
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
- ckfree((char *) csPtr);
+ ckfree(csPtr);
}
/*
@@ -9603,7 +10065,7 @@ StackSetBlockMode(
while (chanPtr != NULL) {
blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
if (blockModeProc != NULL) {
- result = (*blockModeProc) (chanPtr->instanceData, mode);
+ result = blockModeProc(chanPtr->instanceData, mode);
if (result != 0) {
Tcl_SetErrno(result);
return result;
@@ -9756,10 +10218,11 @@ Tcl_GetChannelNamesEx(
}
goto done;
}
+
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
-
statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
+
if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
name = "stdin";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
@@ -9905,11 +10368,8 @@ Tcl_IsChannelExisting(
name = statePtr->channelName;
}
- /* Bug 2333466. Include \0 in the compare to prevent partial matching
- * on prefixes.
- */
if ((*chanName == *name) &&
- (memcmp(name, chanName, (size_t) chanNameLen+1) == 0)) {
+ (memcmp(name, chanName, (size_t) chanNameLen + 1) == 0)) {
return 1;
}
}
@@ -10028,13 +10488,13 @@ Tcl_ChannelBlockModeProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->blockModeProc;
- } else {
- /*
- * The v1 structure had the blockModeProc in a different place.
- */
-
- return (Tcl_DriverBlockModeProc *) (chanTypePtr->version);
}
+
+ /*
+ * The v1 structure had the blockModeProc in a different place.
+ */
+
+ return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
/*
@@ -10276,9 +10736,8 @@ Tcl_ChannelFlushProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->flushProc;
- } else {
- return NULL;
}
+ return NULL;
}
/*
@@ -10304,9 +10763,8 @@ Tcl_ChannelHandlerProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->handlerProc;
- } else {
- return NULL;
}
+ return NULL;
}
/*
@@ -10332,9 +10790,8 @@ Tcl_ChannelWideSeekProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
return chanTypePtr->wideSeekProc;
- } else {
- return NULL;
}
+ return NULL;
}
/*
@@ -10361,9 +10818,8 @@ Tcl_ChannelThreadActionProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
return chanTypePtr->threadActionProc;
- } else {
- return NULL;
}
+ return NULL;
}
/*
@@ -10480,7 +10936,7 @@ FixLevelCode(
res = Tcl_ListObjGetElements(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
- Tcl_Panic("Tcl_SetChannelError(Interp): Bad syntax of message");
+ Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
explicitResult = (1 == (lc % 2));
@@ -10540,7 +10996,7 @@ FixLevelCode(
lcn += 2;
}
- lvn = (Tcl_Obj **) ckalloc(lcn * sizeof(Tcl_Obj *));
+ lvn = ckalloc(lcn * sizeof(Tcl_Obj *));
/*
* New level/code information is spliced into the first occurence of
@@ -10593,7 +11049,7 @@ FixLevelCode(
msg = Tcl_NewListObj(j, lvn);
- ckfree((char *) lvn);
+ ckfree(lvn);
return msg;
}
@@ -10677,9 +11133,8 @@ Tcl_ChannelTruncateProc(
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) {
return chanTypePtr->truncateProc;
- } else {
- return NULL;
}
+ return NULL;
}
/*
@@ -10708,11 +11163,11 @@ DupChannelIntRep(
* currently have an internal rep.*/
{
ChannelState *statePtr = GET_CHANNELSTATE(srcPtr);
- Interp *interpPtr = GET_CHANNELINTERP(srcPtr);
+ Interp *interpPtr = GET_CHANNELINTERP(srcPtr);
SET_CHANNELSTATE(copyPtr, statePtr);
SET_CHANNELINTERP(copyPtr, interpPtr);
- Tcl_Preserve((ClientData) statePtr);
+ Tcl_Preserve(statePtr);
copyPtr->typePtr = &tclChannelType;
}
@@ -10739,7 +11194,7 @@ SetChannelFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
ChannelState *statePtr;
- Interp *interpPtr;
+ Interp *interpPtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -10749,15 +11204,16 @@ SetChannelFromAny(
* The channel is valid until any call to DetachChannel occurs.
* Ensure consistency checks are done.
*/
- statePtr = GET_CHANNELSTATE(objPtr);
+
+ statePtr = GET_CHANNELSTATE(objPtr);
interpPtr = GET_CHANNELINTERP(objPtr);
- if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) {
+ if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
ResetFlag(statePtr, CHANNEL_TAINTED);
- Tcl_Release((ClientData) statePtr);
+ Tcl_Release(statePtr);
UpdateStringOfChannel(objPtr);
objPtr->typePtr = NULL;
} else if (interpPtr != (Interp*) interp) {
- Tcl_Release((ClientData) statePtr);
+ Tcl_Release(statePtr);
UpdateStringOfChannel(objPtr);
objPtr->typePtr = NULL;
}
@@ -10769,6 +11225,7 @@ SetChannelFromAny(
* We need a valid string with which to check for a valid channel, but
* make sure not to free internal rep until validated. [Bug 1847044]
*/
+
if ((objPtr->typePtr != NULL) && (objPtr->bytes == NULL)) {
objPtr->typePtr->updateStringProc(objPtr);
}
@@ -10779,8 +11236,8 @@ SetChannelFromAny(
}
TclFreeIntRep(objPtr);
- statePtr = ((Channel *)chan)->state;
- Tcl_Preserve((ClientData) statePtr);
+ statePtr = ((Channel *) chan)->state;
+ Tcl_Preserve(statePtr);
SET_CHANNELSTATE(objPtr, statePtr);
SET_CHANNELINTERP(objPtr, interp);
objPtr->typePtr = &tclChannelType;
@@ -10813,9 +11270,11 @@ UpdateStringOfChannel(
if (objPtr->bytes == NULL) {
ChannelState *statePtr = GET_CHANNELSTATE(objPtr);
const char *name = statePtr->channelName;
+
if (name) {
size_t len = strlen(name);
- objPtr->bytes = (char *) ckalloc(len + 1);
+
+ objPtr->bytes = ckalloc(len + 1);
objPtr->length = len;
memcpy(objPtr->bytes, name, len);
} else {
@@ -10845,7 +11304,8 @@ static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- Tcl_Release((ClientData) GET_CHANNELSTATE(objPtr));
+ Tcl_Release(GET_CHANNELSTATE(objPtr));
+ objPtr->typePtr = NULL;
}
#if 0
@@ -10862,7 +11322,7 @@ DumpFlags(
char buf[20];
int i = 0;
-#define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
+#define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
ChanFlag('r', TCL_READABLE);
ChanFlag('w', TCL_WRITABLE);
@@ -10897,5 +11357,7 @@ DumpFlags(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclIO.h b/generic/tclIO.h
index 8746a09..3283c3e 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -40,7 +40,7 @@ typedef struct CopyState {
struct Channel *writePtr; /* Pointer to output channel. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
- int toRead; /* Number of bytes to copy, or -1. */
+ 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. */
@@ -63,13 +63,13 @@ typedef struct ChannelBuffer {
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
- char buf[4]; /* Placeholder for real buffer. The real
- * buffer occuppies this space + bufSize-4
+ char buf[1]; /* Placeholder for real buffer. The real
+ * buffer occuppies this space + bufSize-1
* bytes. This must be the last field in the
* structure. */
} ChannelBuffer;
-#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4)
+#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf)
/*
* How much extra space to allocate in buffer to hold bytes from previous
@@ -130,7 +130,7 @@ typedef struct Channel {
struct ChannelState *state; /* Split out state information */
ClientData instanceData; /* Instance-specific data provided by creator
* of channel. */
- Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
+ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
* upon. This reference is NULL for normal
* channels. See Tcl_StackChannel. */
@@ -156,7 +156,7 @@ typedef struct Channel {
*/
typedef struct ChannelState {
- CONST char *channelName; /* The name of the channel instance in Tcl
+ const char *channelName; /* The name of the channel instance in Tcl
* commands. Storage is owned by the generic
* IO code, is dynamically allocated. */
int flags; /* ORed combination of the flags defined
@@ -337,6 +337,9 @@ typedef struct ChannelState {
* Used by Channel Tcl_Obj type to
* determine if we have to revalidate
* the channel. */
+#define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed.
+ * No further Tcl-level write IO on
+ * the channel is allowed. */
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index e166e94..9294dd6 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -16,8 +16,8 @@
*/
typedef struct AcceptCallback {
- char *script; /* Script to invoke. */
- Tcl_Interp *interp; /* Interpreter in which to run it. */
+ char *script; /* Script to invoke. */
+ Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
/*
@@ -117,12 +117,12 @@ Tcl_PutsObjCmd(
ThreadSpecificData *tsdPtr;
switch (objc) {
- case 2: /* [puts $x] */
+ case 2: /* [puts $x] */
string = objv[1];
newline = 1;
break;
- case 3: /* [puts -nonewline $x] or [puts $chan $x] */
+ case 3: /* [puts -nonewline $x] or [puts $chan $x] */
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 0;
} else {
@@ -132,12 +132,14 @@ Tcl_PutsObjCmd(
string = objv[2];
break;
- case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
+ case 4: /* [puts -nonewline $chan $x] or
+ * [puts $chan $x nonewline] */
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
chanObjPtr = objv[2];
string = objv[3];
break;
+#if TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
@@ -149,10 +151,11 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[1];
string = objv[2];
break;
+#endif
}
/* Fall through */
- default:
- /* [puts] or [puts some bad number of arguments...] */
+ default: /* [puts] or
+ * [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
@@ -198,9 +201,8 @@ Tcl_PutsObjCmd(
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error writing \"",
- TclGetString(chanObjPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr),
+ "\": ", Tcl_PosixError(interp), NULL);
}
return TCL_ERROR;
}
@@ -258,8 +260,8 @@ Tcl_FlushObjCmd(
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_AppendResult(interp, "error flushing \"",
- TclGetString(chanObjPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
+ NULL);
}
return TCL_ERROR;
}
@@ -317,10 +319,10 @@ Tcl_GetsObjCmd(
Tcl_DecrRefCount(linePtr);
/*
- * TIP #219. Capture error messages put by the driver into the
- * bypass area and put them into the regular interpreter result.
- * Fall back to the regular message if nothing was found in the
- * bypass.
+ * TIP #219.
+ * Capture error messages put by the driver into the bypass area
+ * and put them into the regular interpreter result. Fall back to
+ * the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
@@ -339,7 +341,6 @@ Tcl_GetsObjCmd(
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
- return TCL_OK;
} else {
Tcl_SetObjResult(interp, linePtr);
}
@@ -392,7 +393,6 @@ Tcl_ReadObjCmd(
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId");
- iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
@@ -416,7 +416,7 @@ Tcl_ReadObjCmd(
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
- i++; /* Consumed channel name. */
+ i++; /* Consumed channel name. */
/*
* Compute how many bytes to read.
@@ -424,7 +424,9 @@ Tcl_ReadObjCmd(
toRead = -1;
if (i < objc) {
- if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
+ if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
+ || (toRead < 0)) {
+#if TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -433,15 +435,16 @@ Tcl_ReadObjCmd(
*/
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
- return TCL_ERROR;
- }
- newline = 1;
- } else if (toRead < 0) {
+#endif
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected non-negative integer but got \"",
TclGetString(objv[i]), "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
+#if TCL_MAJOR_VERSION < 9
+ }
+ newline = 1;
+#endif
}
}
@@ -459,8 +462,8 @@ Tcl_ReadObjCmd(
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"",
- TclGetString(chanObjPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
+ NULL);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
@@ -471,7 +474,7 @@ Tcl_ReadObjCmd(
*/
if ((charactersRead > 0) && (newline != 0)) {
- char *result;
+ const char *result;
int length;
result = TclGetStringFromObj(resultPtr, &length);
@@ -515,7 +518,7 @@ Tcl_SeekObjCmd(
int mode; /* How to seek? */
Tcl_WideInt result; /* Of calling Tcl_Seek. */
int optionIndex;
- static const char *originOptions[] = {
+ static const char *const originOptions[] = {
"start", "current", "end", NULL
};
static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
@@ -547,10 +550,11 @@ Tcl_SeekObjCmd(
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
+
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_AppendResult(interp, "error during seek on \"",
- TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
+ NULL);
}
return TCL_ERROR;
}
@@ -641,9 +645,13 @@ Tcl_CloseObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
+ static const char *const dirOptions[] = {
+ "read", "write", NULL
+ };
+ static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "channelId");
+ if ((objc != 2) && (objc != 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?");
return TCL_ERROR;
}
@@ -651,6 +659,45 @@ Tcl_CloseObjCmd(
return TCL_ERROR;
}
+ if (objc == 3) {
+ int index, dir;
+
+ /*
+ * Get direction requested to close, and check syntax.
+ */
+
+ if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ dir = dirArray[index];
+
+ /*
+ * Check direction against channel mode. It is an error if we try to
+ * close a direction not supported by the channel (already closed, or
+ * never opened for that direction).
+ */
+
+ if (!(dir & Tcl_GetChannelMode(chan))) {
+ Tcl_AppendResult(interp, "Half-close of ", dirOptions[index],
+ "-side not possible, side not opened or already closed",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Special handling is needed if and only if the channel mode supports
+ * more than the direction to close. Because if the close the last
+ * direction suppported we can and will go through the regular
+ * process.
+ */
+
+ if ((Tcl_GetChannelMode(chan) &
+ (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) {
+ return Tcl_CloseEx(interp, chan, dir);
+ }
+ }
+
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove the
@@ -664,7 +711,7 @@ Tcl_CloseObjCmd(
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- char *string;
+ const char *string;
int len;
if (Tcl_IsShared(resultPtr)) {
@@ -706,13 +753,12 @@ Tcl_FconfigureObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *optionName, *valueName;
+ const char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "channelId ?optionName? ?value? ?optionName value?...");
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?");
return TCL_ERROR;
}
@@ -823,19 +869,14 @@ Tcl_ExecObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- /*
- * This function generates an argv array for the string arguments. It
- * starts out with stack-allocated space but uses dynamically-allocated
- * storage if needed.
- */
-
Tcl_Obj *resultPtr;
- const char **argv;
- char *string;
+ const char **argv; /* An array for the string arguments. Stored
+ * on the _Tcl_ stack. */
+ const char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
- static const char *options[] = {
+ static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
@@ -867,7 +908,7 @@ Tcl_ExecObjCmd(
}
}
if (objc <= skip) {
- Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? arg ?arg ...?");
return TCL_ERROR;
}
@@ -888,8 +929,7 @@ Tcl_ExecObjCmd(
*/
argc = objc - skip;
- argv = (const char **)
- TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
+ argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
@@ -901,13 +941,13 @@ Tcl_ExecObjCmd(
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
- (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)));
+ ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR));
/*
* Free the argv array.
*/
- TclStackFree(interp, (void *)argv);
+ TclStackFree(interp, (void *) argv);
if (chan == NULL) {
return TCL_ERROR;
@@ -1057,15 +1097,17 @@ Tcl_OpenObjCmd(
} else {
modeString = TclGetString(objv[2]);
if (objc == 4) {
- char *permString = TclGetString(objv[3]);
+ const char *permString = TclGetString(objv[3]);
int code = TCL_ERROR;
int scanned = TclParseAllWhiteSpace(permString, -1);
- /* Support legacy octal numbers */
+ /*
+ * Support legacy octal numbers.
+ */
+
if ((permString[scanned] == '0')
&& (permString[scanned+1] >= '0')
&& (permString[scanned+1] <= '7')) {
-
Tcl_Obj *permObj;
TclNewLiteralStringObj(permObj, "0o");
@@ -1126,7 +1168,7 @@ Tcl_OpenObjCmd(
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
- ckfree((char *) cmdArgv);
+ ckfree(cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
@@ -1175,7 +1217,7 @@ TcpAcceptCallbacksDeleteProc(
acceptCallbackPtr->interp = NULL;
}
Tcl_DeleteHashTable(hTblPtr);
- ckfree((char *) hTblPtr);
+ ckfree(hTblPtr);
}
/*
@@ -1212,17 +1254,16 @@ RegisterTcpServerInterpCleanup(
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
- hTblPtr = (Tcl_HashTable *)
- Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
- hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
+ hTblPtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
- (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
+ Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
}
- hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew);
+ hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew);
if (!isNew) {
Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table");
}
@@ -1259,8 +1300,7 @@ UnregisterTcpServerInterpCleanupProc(
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
- "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
@@ -1298,7 +1338,7 @@ AcceptCallbackProc(
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
- AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData;
+ AcceptCallback *acceptCallbackPtr = callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
@@ -1328,7 +1368,7 @@ AcceptCallbackProc(
result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
" ", address, " ", portBuf, NULL);
if (result != TCL_OK) {
- TclBackgroundException(interp, result);
+ Tcl_BackgroundException(interp, result);
Tcl_UnregisterChannel(interp, chan);
}
@@ -1343,8 +1383,8 @@ AcceptCallbackProc(
Tcl_Release(script);
} else {
/*
- * The interpreter has been deleted, so there is no useful way to
- * utilize the client socket - just close it.
+ * The interpreter has been deleted, so there is no useful way to use
+ * the client socket - just close it.
*/
Tcl_Close(NULL, chan);
@@ -1377,7 +1417,7 @@ TcpServerCloseProc(
ClientData callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
- AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData;
+ AcceptCallback *acceptCallbackPtr = callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
@@ -1385,7 +1425,7 @@ TcpServerCloseProc(
acceptCallbackPtr);
}
Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
- ckfree((char *) acceptCallbackPtr);
+ ckfree(acceptCallbackPtr);
}
/*
@@ -1412,14 +1452,14 @@ Tcl_SocketObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *socketOptions[] = {
- "-async", "-myaddr", "-myport","-server", NULL
+ static const char *const socketOptions[] = {
+ "-async", "-myaddr", "-myport", "-server", NULL
};
enum socketOptions {
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
};
int optionIndex, a, server = 0, port, myport = 0, async = 0;
- char *host, *script = NULL, *myaddr = NULL;
+ const char *host, *script = NULL, *myaddr = NULL;
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
@@ -1455,7 +1495,7 @@ Tcl_SocketObjCmd(
myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
- char *myPortName;
+ const char *myPortName;
a++;
if (a >= objc) {
@@ -1508,7 +1548,6 @@ Tcl_SocketObjCmd(
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
"-server command ?-myaddr addr? port");
- iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
@@ -1522,8 +1561,8 @@ Tcl_SocketObjCmd(
}
if (server) {
- AcceptCallback *acceptCallbackPtr = (AcceptCallback *)
- ckalloc((unsigned) sizeof(AcceptCallback));
+ AcceptCallback *acceptCallbackPtr =
+ ckalloc(sizeof(AcceptCallback));
unsigned len = strlen(script) + 1;
char *copyScript = ckalloc(len);
@@ -1534,7 +1573,7 @@ Tcl_SocketObjCmd(
acceptCallbackPtr);
if (chan == NULL) {
ckfree(copyScript);
- ckfree((char *) acceptCallbackPtr);
+ ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
@@ -1592,9 +1631,10 @@ Tcl_FcopyObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel inChan, outChan;
- int mode, i, toRead, index;
+ int mode, i, index;
+ Tcl_WideInt toRead;
Tcl_Obj *cmdPtr;
- static const char* switches[] = { "-size", "-command", NULL };
+ static const char *const switches[] = { "-size", "-command", NULL };
enum { FcopySize, FcopyCommand };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
@@ -1634,16 +1674,17 @@ Tcl_FcopyObjCmd(
}
switch (index) {
case FcopySize:
- if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
return TCL_ERROR;
}
- if (toRead<0) {
+ if (toRead < 0) {
/*
* Handle all negative sizes like -1, meaning 'copy all'. By
* resetting toRead we avoid changes in the core copying
* functions (which explicitly check for -1 and crash on any
* other negative value).
*/
+
toRead = -1;
}
break;
@@ -1685,7 +1726,7 @@ ChanPendingObjCmd(
{
Tcl_Channel chan;
int index, mode;
- static const char *options[] = {"input", "output", NULL};
+ static const char *const options[] = {"input", "output", NULL};
enum options {PENDING_INPUT, PENDING_OUTPUT};
if (objc != 3) {
@@ -1797,6 +1838,90 @@ ChanTruncateObjCmd(
/*
*----------------------------------------------------------------------
*
+ * ChanPipeObjCmd --
+ *
+ * This function is invoked to process the "chan pipe" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates a pair of Tcl channels wrapping both ends of a new
+ * anonymous pipe.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ChanPipeObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Channel rchan, wchan;
+ const char *channelNames[2];
+ Tcl_Obj *resultPtr;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ channelNames[0] = Tcl_GetChannelName(rchan);
+ channelNames[1] = Tcl_GetChannelName(wchan);
+
+ resultPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewStringObj(channelNames[0], -1));
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewStringObj(channelNames[1], -1));
+ Tcl_SetObjResult(interp, resultPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChannelNamesCmd --
+ *
+ * This function is invoked to process the "chan names" and "file
+ * channels" Tcl commands. See the user documentation for details on
+ * what they do.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChannelNamesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc < 1 || objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+ return Tcl_GetChannelNamesEx(interp,
+ ((objc == 1) ? NULL : TclGetString(objv[1])));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInitChanCmd --
*
* This function is invoked to create the "chan" Tcl command. See the
@@ -1823,26 +1948,29 @@ TclInitChanCmd(
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
- {"blocked", Tcl_FblockedObjCmd},
- {"close", Tcl_CloseObjCmd},
- {"copy", Tcl_FcopyObjCmd},
- {"create", TclChanCreateObjCmd}, /* TIP #219 */
- {"eof", Tcl_EofObjCmd},
- {"event", Tcl_FileEventObjCmd},
- {"flush", Tcl_FlushObjCmd},
- {"gets", Tcl_GetsObjCmd},
- {"pending", ChanPendingObjCmd}, /* TIP #287 */
- {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */
- {"puts", Tcl_PutsObjCmd},
- {"read", Tcl_ReadObjCmd},
- {"seek", Tcl_SeekObjCmd},
- {"tell", Tcl_TellObjCmd},
- {"truncate", ChanTruncateObjCmd}, /* TIP #208 */
- {NULL}
+ {"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 */
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
- static const char *extras[] = {
+ static const char *const extras[] = {
"configure", "::fconfigure",
- "names", "::file channels",
NULL
};
Tcl_Command ensemble;
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 5dae459..6f80c25 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -116,7 +116,7 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf,
* transformations.
*/
-static Tcl_ChannelType transformChannelType = {
+static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TransformCloseProc, /* Close proc. */
@@ -133,7 +133,7 @@ static Tcl_ChannelType transformChannelType = {
TransformNotifyProc, /* Handling of events bubbling up. */
TransformWideSeekProc, /* Wide seek proc. */
NULL, /* Thread action. */
- NULL, /* Truncate. */
+ NULL /* Truncate. */
};
/*
@@ -259,7 +259,7 @@ TclChannelTransform(
* regime of the underlying channel and to use the same for us too.
*/
- dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData));
+ dataPtr = ckalloc(sizeof(TransformChannelData));
Tcl_DStringInit(&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
@@ -288,7 +288,7 @@ TclChannelTransform(
Tcl_GetChannelName(chan), "\"", NULL);
Tcl_DecrRefCount(dataPtr->command);
ResultClear(&dataPtr->result);
- ckfree((char *) dataPtr);
+ ckfree(dataPtr);
return TCL_ERROR;
}
@@ -561,7 +561,7 @@ TransformCloseProc(
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
- ckfree((char *) dataPtr);
+ ckfree(dataPtr);
return TCL_OK;
}
@@ -800,7 +800,7 @@ TransformSeekProc(
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
- Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
+ const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
if ((offset == 0) && (mode == SEEK_CUR)) {
@@ -864,7 +864,7 @@ TransformWideSeekProc(
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
- Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
+ const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
@@ -1227,7 +1227,7 @@ ResultClear(
r->used = 0;
if (r->allocated) {
- ckfree((char *) r->buf);
+ ckfree(r->buf);
r->buf = NULL;
r->allocated = 0;
}
@@ -1371,10 +1371,10 @@ ResultAdd(
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
- r->buf = UCHARP(ckalloc(r->allocated));
+ r->buf = ckalloc(r->allocated);
} else {
r->allocated += toWrite + INCREMENT;
- r->buf = UCHARP(ckrealloc((char *) r->buf, r->allocated));
+ r->buf = ckrealloc(r->buf, r->allocated);
}
}
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index d3bd8c4..683e2e4 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -16,8 +16,8 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include <tclInt.h>
-#include <tclIO.h>
+#include "tclInt.h"
+#include "tclIO.h"
#include <assert.h>
#ifndef EINVAL
@@ -55,24 +55,24 @@ static int ReflectSetOption(ClientData clientData,
* a version 3 structure.
*/
-static Tcl_ChannelType tclRChannelType = {
- "tclrchannel", /* Type name. */
+static const Tcl_ChannelType tclRChannelType = {
+ "tclrchannel", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- ReflectClose, /* Close channel, clean instance data */
- ReflectInput, /* Handle read request */
- ReflectOutput, /* Handle write request */
- ReflectSeek, /* Move location of access point. NULL'able */
- ReflectSetOption, /* Set options. NULL'able */
- ReflectGetOption, /* Get options. NULL'able */
- ReflectWatch, /* Initialize notifier */
- NULL, /* Get OS handle from the channel. NULL'able */
- NULL, /* No close2 support. NULL'able */
- ReflectBlock, /* Set blocking/nonblocking. NULL'able */
- NULL, /* Flush channel. Not used by core. NULL'able */
- NULL, /* Handle events. NULL'able */
- ReflectSeekWide, /* Move access point (64 bit). NULL'able */
- NULL, /* thread action */
- NULL, /* truncate */
+ ReflectClose, /* Close channel, clean instance data */
+ ReflectInput, /* Handle read request */
+ ReflectOutput, /* Handle write request */
+ ReflectSeek, /* Move location of access point. NULL'able */
+ ReflectSetOption, /* Set options. NULL'able */
+ ReflectGetOption, /* Get options. NULL'able */
+ ReflectWatch, /* Initialize notifier */
+ NULL, /* Get OS handle from the channel. NULL'able */
+ NULL, /* No close2 support. NULL'able */
+ ReflectBlock, /* Set blocking/nonblocking. NULL'able */
+ NULL, /* Flush channel. Not used by core. NULL'able */
+ NULL, /* Handle events. NULL'able */
+ ReflectSeekWide, /* Move access point (64 bit). NULL'able */
+ NULL, /* thread action */
+ NULL /* truncate */
};
/*
@@ -159,7 +159,7 @@ typedef struct {
* Event literals. ==================================================
*/
-static const char *eventOptions[] = {
+static const char *const eventOptions[] = {
"read", "write", NULL
};
typedef enum {
@@ -170,7 +170,7 @@ typedef enum {
* Method literals. ==================================================
*/
-static const char *methodNames[] = {
+static const char *const methodNames[] = {
"blocking", /* OPT */
"cget", /* OPT \/ Together or none */
"cgetall", /* OPT /\ of these two */
@@ -340,7 +340,8 @@ typedef struct ForwardingEvent {
struct ForwardingResult {
Tcl_ThreadId src; /* Originating thread. */
Tcl_ThreadId dst; /* Thread the op was forwarded to. */
- Tcl_Interp* dsti; /* Interpreter in the thread the op was forwarded to. */
+ Tcl_Interp *dsti; /* Interpreter in the thread the op was
+ * forwarded to. */
/*
* Note regarding 'dsti' above: Its information is also available via the
* chain evPtr->rcPtr->interp, however, as can be seen, two more
@@ -362,7 +363,7 @@ typedef struct ThreadSpecificData {
* per-thread version of the per-interpreter map.
*/
- ReflectedChannelMap* rcmPtr;
+ ReflectedChannelMap *rcmPtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -387,7 +388,7 @@ TCL_DECLARE_MUTEX(rcForwardMutex)
*/
static void ForwardOpToOwnerThread(ReflectedChannel *rcPtr,
- ForwardedOperation op, const VOID *param);
+ ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
@@ -445,7 +446,7 @@ static int InvokeTclMethod(ReflectedChannel *rcPtr,
static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
static void DeleteReflectedChannelMap(ClientData clientData,
Tcl_Interp *interp);
-static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj);
+static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
/*
* Global constant strings (messages). ==================
@@ -511,9 +512,11 @@ TclChanCreateObjCmd(
int methods; /* Bitmask for supported methods. */
Channel *chanPtr; /* 'chan' resolved to internal struct. */
Tcl_Obj *err; /* Error message */
- ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
- Tcl_HashEntry* hPtr; /* Entry in the above map */
- int isNew; /* Placeholder. */
+ ReflectedChannelMap *rcmPtr;
+ /* Map of reflected channels with handlers in
+ * this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
+ int isNew; /* Placeholder. */
/*
* Syntax: chan create MODE CMDPREFIX
@@ -587,6 +590,7 @@ TclChanCreateObjCmd(
/* assert modeObj.refCount == 1 */
result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj);
Tcl_DecrRefCount(modeObj);
+
if (result != TCL_OK) {
UnmarshallErrorResult(interp, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
@@ -683,8 +687,7 @@ TclChanCreateObjCmd(
* as the actual channel type.
*/
- Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)
- ckalloc(sizeof(Tcl_ChannelType));
+ Tcl_ChannelType *clonePtr = ckalloc(sizeof(Tcl_ChannelType));
memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
@@ -713,19 +716,17 @@ TclChanCreateObjCmd(
Tcl_RegisterChannel(interp, chan);
- rcmPtr = GetReflectedChannelMap (interp);
- hPtr = Tcl_CreateHashEntry(&rcmPtr->map,
- chanPtr->state->channelName, &isNew);
- if (!isNew) {
- if (chanPtr != Tcl_GetHashValue(hPtr)) {
- Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
- }
+ rcmPtr = GetReflectedChannelMap(interp);
+ hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
+ &isNew);
+ if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) {
+ Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
}
Tcl_SetHashValue(hPtr, chan);
#ifdef TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
- hPtr = Tcl_CreateHashEntry(&rcmPtr->map,
- chanPtr->state->channelName, &isNew);
+ hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
+ &isNew);
Tcl_SetHashValue(hPtr, chan);
#endif
@@ -733,10 +734,10 @@ TclChanCreateObjCmd(
* Return handle as result of command.
*/
- Tcl_SetObjResult(interp, rcId);
+ Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE);
return TCL_OK;
- error:
+ error:
/*
* Signal to ReflectClose to not call 'finalize'.
*/
@@ -793,8 +794,9 @@ TclChanPostEventObjCmd(
/* Its associated driver structure */
ReflectedChannel *rcPtr; /* Associated instance data */
int events; /* Mask of events to post */
- ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
- Tcl_HashEntry* hPtr; /* Entry in the above map */
+ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
+ * this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
/*
* Number of arguments...
@@ -812,12 +814,12 @@ TclChanPostEventObjCmd(
chanId = TclGetString(objv[CHAN]);
- rcmPtr = GetReflectedChannelMap (interp);
- hPtr = Tcl_FindHashEntry (&rcmPtr->map, chanId);
+ rcmPtr = GetReflectedChannelMap(interp);
+ hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "can not find reflected channel named \"", chanId,
- "\"", NULL);
+ Tcl_AppendResult(interp, "can not find reflected channel named \"",
+ chanId, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL);
return TCL_ERROR;
}
@@ -838,7 +840,7 @@ TclChanPostEventObjCmd(
* have gone seriously haywire.
*/
- chan = Tcl_GetHashValue(hPtr);
+ chan = Tcl_GetHashValue(hPtr);
chanTypePtr = Tcl_GetChannelType(chan);
/*
@@ -851,13 +853,13 @@ TclChanPostEventObjCmd(
*/
if (chanTypePtr->watchProc != &ReflectWatch) {
- Tcl_Panic ("TclChanPostEventObjCmd: channel is not a reflected channel");
+ Tcl_Panic("TclChanPostEventObjCmd: channel is not a reflected channel");
}
- rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+ rcPtr = Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
- Tcl_Panic ("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter");
+ Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter");
}
/*
@@ -900,7 +902,7 @@ TclChanPostEventObjCmd(
* Channel error message marshalling utilities.
*/
-static Tcl_Obj*
+static Tcl_Obj *
MarshallError(
Tcl_Interp *interp)
{
@@ -955,7 +957,7 @@ UnmarshallErrorResult(
}
(void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
- ((Interp *)interp)->flags &= ~ERR_ALREADY_LOGGED;
+ ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED;
}
int
@@ -1040,11 +1042,12 @@ ReflectClose(
ClientData clientData,
Tcl_Interp *interp)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
int result; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
- ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
- Tcl_HashEntry* hPtr; /* Entry in the above map */
+ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
+ * this interp */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
if (TclInThreadExit()) {
/*
@@ -1058,8 +1061,9 @@ ReflectClose(
/*
* THREADED => Forward this to the origin thread
*
- * Note: DeleteThreadReflectedChannelMap() is the thread exit handler for the origin
- * thread. Use this to clean up the structure? Except if lost?
+ * Note: DeleteThreadReflectedChannelMap() is the thread exit handler
+ * for the origin thread. Use this to clean up the structure? Except
+ * if lost?
*/
#ifdef TCL_THREADS
@@ -1140,19 +1144,19 @@ ReflectClose(
*/
if (rcPtr->interp) {
- rcmPtr = GetReflectedChannelMap (rcPtr->interp);
- hPtr = Tcl_FindHashEntry (&rcmPtr->map,
- Tcl_GetChannelName (rcPtr->chan));
+ rcmPtr = GetReflectedChannelMap(rcPtr->interp);
+ hPtr = Tcl_FindHashEntry(&rcmPtr->map,
+ Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_DeleteHashEntry(hPtr);
}
}
#ifdef TCL_THREADS
- rcmPtr = GetThreadReflectedChannelMap();
- hPtr = Tcl_FindHashEntry (&rcmPtr->map,
- Tcl_GetChannelName (rcPtr->chan));
+ rcmPtr = GetThreadReflectedChannelMap();
+ hPtr = Tcl_FindHashEntry(&rcmPtr->map,
+ Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_DeleteHashEntry(hPtr);
}
#endif
@@ -1186,7 +1190,7 @@ ReflectInput(
int toRead,
int *errorCodePtr)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *toReadObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
@@ -1243,7 +1247,7 @@ ReflectInput(
Tcl_IncrRefCount(toReadObj);
if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) {
- int code = ErrnoReturn (rcPtr, resObj);
+ int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
@@ -1302,7 +1306,7 @@ ReflectOutput(
int toWrite,
int *errorCodePtr)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *bufObj;
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
@@ -1430,7 +1434,7 @@ ReflectSeekWide(
int seekMode,
int *errorCodePtr)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *offObj, *baseObj;
Tcl_Obj *resObj; /* Result for 'seek' */
Tcl_WideInt newLoc;
@@ -1464,9 +1468,9 @@ ReflectSeekWide(
Tcl_Preserve(rcPtr);
- offObj = Tcl_NewWideIntObj(offset);
+ offObj = Tcl_NewWideIntObj(offset);
baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" :
- ((seekMode == SEEK_CUR) ? "current" : "end"), -1);
+ ((seekMode == SEEK_CUR) ? "current" : "end"), -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
@@ -1538,7 +1542,7 @@ ReflectWatch(
ClientData clientData,
int mask)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *maskObj;
/* ASSERT rcPtr->methods & FLAG(METH_WATCH) */
@@ -1613,7 +1617,7 @@ ReflectBlock(
ClientData clientData,
int nonblocking)
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *blockObj;
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result data for 'blocking' */
@@ -1644,7 +1648,7 @@ ReflectBlock(
Tcl_Preserve(rcPtr);
- if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj) != TCL_OK) {
+ if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
errorNum = EINVAL;
} else {
@@ -1681,7 +1685,7 @@ ReflectSetOption(
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
- ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *optionObj, *valueObj;
int result; /* Result code for 'configure' */
Tcl_Obj *resObj; /* Result data for 'configure' */
@@ -1758,7 +1762,7 @@ ReflectGetOption(
* The bypass functions are not required.
*/
- ReflectedChannel *rcPtr = (ReflectedChannel*) clientData;
+ ReflectedChannel *rcPtr = clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
int listc, result = TCL_OK;
@@ -1859,7 +1863,7 @@ ReflectGetOption(
goto error;
} else {
int len;
- char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
Tcl_DStringAppend(dsPtr, " ", 1);
@@ -1959,7 +1963,7 @@ EncodeEventMask(
* This function takes an internal bitmask of events and constructs the
* equivalent list of event items.
*
- * Results:
+ * Results, Contract:
* A Tcl_Obj reference. The object will have a refCount of one. The user
* has to decrement it to release the object.
*
@@ -1993,6 +1997,7 @@ DecodeEventMask(
evObj = Tcl_NewStringObj(eventStr, -1);
Tcl_IncrRefCount(evObj);
+ /* assert evObj.refCount == 1 */
return evObj;
}
@@ -2024,7 +2029,7 @@ NewReflectedChannel(
int i, listc;
Tcl_Obj **listv;
- rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel));
+ rcPtr = ckalloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
/* rcPtr->methods: Assigned by caller. Dummy data here. */
@@ -2057,7 +2062,7 @@ NewReflectedChannel(
*/
rcPtr->argc = listc + 2;
- rcPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4));
+ rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4));
/*
* Duplicate object references.
@@ -2143,7 +2148,7 @@ FreeReflectedChannel(
* Delete a cloned ChannelType structure.
*/
- ckfree((char*) chanPtr->typePtr);
+ ckfree(chanPtr->typePtr);
}
n = rcPtr->argc - 2;
@@ -2157,8 +2162,8 @@ FreeReflectedChannel(
Tcl_DecrRefCount(rcPtr->argv[n+1]);
- ckfree((char*) rcPtr->argv);
- ckfree((char*) rcPtr);
+ ckfree(rcPtr->argv);
+ ckfree(rcPtr);
}
/*
@@ -2237,6 +2242,9 @@ InvokeTclMethod(
/*
* Append the additional argument containing method specific details
* behind the channel id. If specified.
+ *
+ * Because of the contract there is no need to increment the refcounts.
+ * The objects will survive the Tcl_EvalObjv without change.
*/
cmdc = rcPtr->argc;
@@ -2353,7 +2361,9 @@ InvokeTclMethod(
*/
static int
-ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj)
+ErrnoReturn(
+ ReflectedChannel *rcPtr,
+ Tcl_Obj *resObj)
{
int code;
Tcl_InterpState sr; /* State of handler interp */
@@ -2367,9 +2377,10 @@ ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj)
resObj = Tcl_GetObjResult(rcPtr->interp);
- if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) {
- if (strcmp ("EAGAIN",Tcl_GetString(resObj)) == 0) {
- code = - EAGAIN;
+ if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK)
+ || (code >= 0))) {
+ if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) {
+ code = -EAGAIN;
} else {
code = 0;
}
@@ -2400,10 +2411,10 @@ static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
- ReflectedChannelMap* rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
+ ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
if (rcmPtr == NULL) {
- rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+ rcmPtr = ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RCMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
@@ -2436,12 +2447,12 @@ DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
- ReflectedChannelMap* rcmPtr; /* The map */
+ ReflectedChannelMap *rcmPtr = clientData;
+ /* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
- ReflectedChannel* rcPtr;
+ ReflectedChannel *rcPtr;
Tcl_Channel chan;
-
#ifdef TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
@@ -2451,7 +2462,7 @@ DeleteReflectedChannelMap(
/*
* Delete all entries. The channels may have been closed already, or will
* be closed later, by the standard IO finalization of an interpreter
- * under destruction. Except for the channels which were moved to a
+ * under destruction. Except for the channels which were moved to a
* different interpreter and/or thread. They do not exist from the IO
* systems point of view and will not get closed. Therefore mark all as
* dead so that any future access will cause a proper error. For channels
@@ -2460,20 +2471,17 @@ DeleteReflectedChannelMap(
* this interp.
*/
- rcmPtr = clientData;
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
-
- chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
- rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
+ chan = Tcl_GetHashValue(hPtr);
+ rcPtr = Tcl_GetChannelInstanceData(chan);
rcPtr->interp = NULL;
-
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
- ckfree((char *) &rcmPtr->map);
+ ckfree(&rcmPtr->map);
#ifdef TCL_THREADS
/*
@@ -2489,10 +2497,13 @@ DeleteReflectedChannelMap(
Tcl_MutexLock(&rcForwardMutex);
for (resultPtr = forwardList;
- resultPtr != NULL;
- resultPtr = resultPtr->nextPtr) {
+ resultPtr != NULL;
+ resultPtr = resultPtr->nextPtr) {
if (resultPtr->dsti != interp) {
- /* Ignore results/events for other interpreters. */
+ /*
+ * Ignore results/events for other interpreters.
+ */
+
continue;
}
@@ -2522,14 +2533,16 @@ DeleteReflectedChannelMap(
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
-
- chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
- rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ chan = Tcl_GetHashValue(hPtr);
+ rcPtr = Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
- /* Ignore entries for other interpreters */
+ /*
+ * Ignore entries for other interpreters.
+ */
+
continue;
}
@@ -2559,12 +2572,12 @@ DeleteReflectedChannelMap(
*/
static ReflectedChannelMap *
-GetThreadReflectedChannelMap()
+GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
- tsdPtr->rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+ tsdPtr->rcmPtr = ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
}
@@ -2579,7 +2592,7 @@ GetThreadReflectedChannelMap()
*
* Deletes the channel table for a thread. This procedure is invoked when
* a thread is deleted. The channels have already been marked as dead, in
- * DeleteReflectedChannelMap().
+ * DeleteReflectedChannelMap().
*
* Results:
* None.
@@ -2597,13 +2610,8 @@ DeleteThreadReflectedChannelMap(
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
-
- ReflectedChannelMap* rcmPtr; /* The map */
- Tcl_Channel chan;
- ReflectedChannel* rcPtr;
+ ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
- ForwardingEvent *evPtr;
- ForwardParam *paramPtr;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2620,10 +2628,16 @@ DeleteThreadReflectedChannelMap(
Tcl_MutexLock(&rcForwardMutex);
for (resultPtr = forwardList;
- resultPtr != NULL;
- resultPtr = resultPtr->nextPtr) {
+ resultPtr != NULL;
+ resultPtr = resultPtr->nextPtr) {
+ ForwardingEvent *evPtr;
+ ForwardParam *paramPtr;
+
if (resultPtr->dst != self) {
- /* Ignore results/events for other threads. */
+ /*
+ * Ignore results/events for other threads.
+ */
+
continue;
}
@@ -2652,14 +2666,12 @@ DeleteThreadReflectedChannelMap(
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
-
- chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
- rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
+ Tcl_Channel chan = Tcl_GetHashValue(hPtr);
+ ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
rcPtr->interp = NULL;
-
Tcl_DeleteHashEntry(hPtr);
}
@@ -2670,12 +2682,11 @@ static void
ForwardOpToOwnerThread(
ReflectedChannel *rcPtr, /* Channel instance */
ForwardedOperation op, /* Forwarded driver operation */
- const VOID *param) /* Arguments */
+ const void *param) /* Arguments */
{
Tcl_ThreadId dst = rcPtr->thread;
ForwardingEvent *evPtr;
ForwardingResult *resultPtr;
- int result;
/*
* We gather the lock early. This allows us to check the liveness of the
@@ -2690,7 +2701,7 @@ ForwardOpToOwnerThread(
* appropriate error. Do not forget to unlock the mutex on this path.
*/
- ForwardSetStaticError((ForwardParam *)param, msg_send_dstlost);
+ ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost);
Tcl_MutexUnlock(&rcForwardMutex);
return;
}
@@ -2699,8 +2710,8 @@ ForwardOpToOwnerThread(
* Create and initialize the event and data structures.
*/
- evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent));
- resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult));
+ evPtr = ckalloc(sizeof(ForwardingEvent));
+ resultPtr = ckalloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
@@ -2708,8 +2719,8 @@ ForwardOpToOwnerThread(
evPtr->rcPtr = rcPtr;
evPtr->param = (ForwardParam *) param;
- resultPtr->src = Tcl_GetCurrentThread();
- resultPtr->dst = dst;
+ resultPtr->src = Tcl_GetCurrentThread();
+ resultPtr->dst = dst;
resultPtr->dsti = rcPtr->interp;
resultPtr->done = NULL;
resultPtr->result = -1;
@@ -2724,19 +2735,19 @@ ForwardOpToOwnerThread(
/*
* Ensure cleanup of the event if the origin thread exits while this event
- * is pending or in progress. Exitus of the destination thread is handled
- * by DeleteThreadReflectionChannelMap(), this is set up by
- * GetThreadReflectedChannelMap(). This is what we use the 'forwardList'
+ * is pending or in progress. Exit of the destination thread is handled by
+ * DeleteThreadReflectionChannelMap(), this is set up by
+ * GetThreadReflectedChannelMap(). This is what we use the 'forwardList'
* (see above) for.
*/
- Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr);
+ Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
/*
* Queue the event and poke the other thread's notifier.
*/
- Tcl_ThreadQueueEvent(dst, (Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
+ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(dst);
/*
@@ -2758,8 +2769,8 @@ ForwardOpToOwnerThread(
}
/*
- * Unlink result from the forwarder list.
- * No need to lock. Either still locked, or locked by the ConditionWait
+ * Unlink result from the forwarder list. No need to lock. Either still
+ * locked, or locked by the ConditionWait
*/
TclSpliceOut(resultPtr, forwardList);
@@ -2777,10 +2788,9 @@ ForwardOpToOwnerThread(
* Note: The event structure has already been deleted.
*/
- Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr);
+ Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
- result = resultPtr->result;
- ckfree((char*) resultPtr);
+ ckfree(resultPtr);
}
static int
@@ -2807,8 +2817,10 @@ ForwardProc(
Tcl_Interp *interp = rcPtr->interp;
ForwardParam *paramPtr = evPtr->param;
Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
- ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
- Tcl_HashEntry* hPtr; /* Entry in the above map */
+ ReflectedChannelMap *rcmPtr;
+ /* Map of reflected channels with handlers in
+ * this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
/*
* Ignore the event if no one is waiting for its result anymore.
@@ -2848,15 +2860,15 @@ ForwardProc(
* 'postevent') from finding and dereferencing a dangling pointer.
*/
- rcmPtr = GetReflectedChannelMap (interp);
- hPtr = Tcl_FindHashEntry (&rcmPtr->map,
- Tcl_GetChannelName (rcPtr->chan));
- Tcl_DeleteHashEntry (hPtr);
+ rcmPtr = GetReflectedChannelMap(interp);
+ hPtr = Tcl_FindHashEntry(&rcmPtr->map,
+ Tcl_GetChannelName(rcPtr->chan));
+ Tcl_DeleteHashEntry(hPtr);
- rcmPtr = GetThreadReflectedChannelMap();
- hPtr = Tcl_FindHashEntry (&rcmPtr->map,
- Tcl_GetChannelName (rcPtr->chan));
- Tcl_DeleteHashEntry (hPtr);
+ rcmPtr = GetThreadReflectedChannelMap();
+ hPtr = Tcl_FindHashEntry(&rcmPtr->map,
+ Tcl_GetChannelName(rcPtr->chan));
+ Tcl_DeleteHashEntry(hPtr);
Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
break;
@@ -2867,7 +2879,7 @@ ForwardProc(
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){
- int code = ErrnoReturn (rcPtr, resObj);
+ int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
@@ -2902,7 +2914,7 @@ ForwardProc(
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
- paramPtr->output.buf, paramPtr->output.toWrite);
+ paramPtr->output.buf, paramPtr->output.toWrite);
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
@@ -2940,8 +2952,8 @@ ForwardProc(
case ForwardedSeek: {
Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
Tcl_Obj *baseObj = Tcl_NewStringObj(
- (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
- (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
+ (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
+ (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
@@ -2993,7 +3005,7 @@ ForwardProc(
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
- &resObj) != TCL_OK) {
+ &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
@@ -3003,13 +3015,13 @@ ForwardProc(
case ForwardedSetOpt: {
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
- Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1);
+ Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
- &resObj) != TCL_OK) {
+ &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
@@ -3031,7 +3043,7 @@ ForwardProc(
ForwardSetObjError(paramPtr, resObj);
} else {
Tcl_DStringAppend(paramPtr->getOpt.value,
- TclGetString(resObj), -1);
+ TclGetString(resObj), -1);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
@@ -3056,7 +3068,7 @@ ForwardProc(
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, resObj, &listc,
- &listv) != TCL_OK) {
+ &listv) != TCL_OK) {
ForwardSetObjError(paramPtr, MarshallError(interp));
} else if ((listc % 2) == 1) {
/*
@@ -3120,7 +3132,7 @@ static void
SrcExitProc(
ClientData clientData)
{
- ForwardingEvent *evPtr = (ForwardingEvent *) clientData;
+ ForwardingEvent *evPtr = clientData;
ForwardingResult *resultPtr;
ForwardParam *paramPtr;
@@ -3173,7 +3185,7 @@ ForwardSetObjError(
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
- ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len));
+ ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
#endif
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
new file mode 100644
index 0000000..5bd77b7
--- /dev/null
+++ b/generic/tclIORTrans.c
@@ -0,0 +1,3400 @@
+/*
+ * tclIORTrans.c --
+ *
+ * This file contains the implementation of Tcl's generic transformation
+ * reflection code, which allows the implementation of Tcl channel
+ * transformations in Tcl code.
+ *
+ * Parts of this file are based on code contributed by Jean-Claude
+ * Wippler.
+ *
+ * See TIP #230 for the specification of this functionality.
+ *
+ * Copyright (c) 2007-2008 ActiveState.
+ *
+ * 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 "tclIO.h"
+#include <assert.h>
+
+#ifndef EINVAL
+#define EINVAL 9
+#endif
+#ifndef EOK
+#define EOK 0
+#endif
+
+/* DUPLICATE of HaveVersion() in tclIO.c // TODO - MODULE_SCOPE */
+static int HaveVersion(const Tcl_ChannelType *typePtr,
+ Tcl_ChannelTypeVersion minimumVersion);
+
+/*
+ * Signatures of all functions used in the C layer of the reflection.
+ */
+
+static int ReflectClose(ClientData clientData,
+ Tcl_Interp *interp);
+static int ReflectInput(ClientData clientData, char *buf,
+ int toRead, int *errorCodePtr);
+static int ReflectOutput(ClientData clientData, const char *buf,
+ int toWrite, int *errorCodePtr);
+static void ReflectWatch(ClientData clientData, int mask);
+static int ReflectBlock(ClientData clientData, int mode);
+static Tcl_WideInt ReflectSeekWide(ClientData clientData,
+ Tcl_WideInt offset, int mode, int *errorCodePtr);
+static int ReflectSeek(ClientData clientData, long offset,
+ int mode, int *errorCodePtr);
+static int ReflectGetOption(ClientData clientData,
+ Tcl_Interp *interp, const char *optionName,
+ Tcl_DString *dsPtr);
+static int ReflectSetOption(ClientData clientData,
+ Tcl_Interp *interp, const char *optionName,
+ const char *newValue);
+static int ReflectHandle(ClientData clientData, int direction,
+ ClientData *handle);
+static int ReflectNotify(ClientData clientData, int mask);
+
+/*
+ * The C layer channel type/driver definition used by the reflection.
+ */
+
+static const Tcl_ChannelType tclRTransformType = {
+ "tclrtransform", /* Type name. */
+ TCL_CHANNEL_VERSION_5, /* v5 channel. */
+ ReflectClose, /* Close channel, clean instance data. */
+ ReflectInput, /* Handle read request. */
+ ReflectOutput, /* Handle write request. */
+ ReflectSeek, /* Move location of access point. */
+ ReflectSetOption, /* Set options. */
+ ReflectGetOption, /* Get options. */
+ ReflectWatch, /* Initialize notifier. */
+ ReflectHandle, /* Get OS handle from the channel. */
+ NULL, /* No close2 support. NULL'able. */
+ ReflectBlock, /* Set blocking/nonblocking. */
+ NULL, /* Flush channel. Not used by core.
+ * NULL'able. */
+ ReflectNotify, /* Handle events. */
+ ReflectSeekWide, /* Move access point (64 bit). */
+ NULL, /* thread action */
+ NULL /* truncate */
+};
+
+/*
+ * Structure of the buffer to hold transform results to be consumed by higher
+ * layers upon reading from the channel, plus the functions to manage such.
+ */
+
+typedef struct _ResultBuffer_ {
+ unsigned char *buf; /* Reference to the buffer area. */
+ int allocated; /* Allocated size of the buffer area. */
+ int used; /* Number of bytes in the buffer,
+ * <= allocated. */
+} ResultBuffer;
+
+#define ResultLength(r) ((r)->used)
+/* static int ResultLength(ResultBuffer *r); */
+
+static void ResultClear(ResultBuffer *r);
+static void ResultInit(ResultBuffer *r);
+static void ResultAdd(ResultBuffer *r, unsigned char *buf,
+ int toWrite);
+static int ResultCopy(ResultBuffer *r, unsigned char *buf,
+ int toRead);
+
+#define RB_INCREMENT (512)
+
+/*
+ * Convenience macro to make some casts easier to use.
+ */
+
+#define UCHARP(x) ((unsigned char *) (x))
+
+/*
+ * Instance data for a reflected transformation. ===========================
+ */
+
+typedef struct {
+ Tcl_Channel chan; /* Back reference to the channel of the
+ * transformation itself. */
+ Tcl_Channel parent; /* Reference to the channel the transformation
+ * was pushed on. */
+ Tcl_Interp *interp; /* Reference to the interpreter containing the
+ * Tcl level part of the channel. */
+ Tcl_Obj *handle; /* Reference to transform handle. Also stored
+ * in the argv, see below. The separate field
+ * gives us direct access, needed when working
+ * with the reflection maps. */
+#ifdef TCL_THREADS
+ Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
+#endif
+
+ Tcl_TimerToken timer;
+
+ /* See [==] as well.
+ * Storage for the command prefix and the additional words required for
+ * the invocation of methods in the command handler.
+ *
+ * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
+ * cmd ... pfx | method chan | detail1 detail2
+ * ~~~~ CT ~~~ ~~ CT ~~
+ *
+ * CT = Belongs to the 'Command handler Thread'.
+ */
+
+ int argc; /* Number of preallocated words - 2. */
+ Tcl_Obj **argv; /* Preallocated array for calling the handler.
+ * args[0] is placeholder for cmd word.
+ * Followed by the arguments in the prefix,
+ * plus 4 placeholders for method, channel,
+ * and at most two varying (method specific)
+ * words. */
+ int methods; /* Bitmask of supported methods. */
+
+ /*
+ * NOTE (9): Should we have predefined shared literals for the method
+ * names?
+ */
+
+ int mode; /* Mask of R/W mode */
+ int nonblocking; /* Flag: Channel is blocking or not. */
+ int readIsDrained; /* Flag: Read buffers are flushed. */
+ ResultBuffer result;
+} ReflectedTransform;
+
+/*
+ * Structure of the table mapping from transform handles to reflected
+ * transform (channels). Each interpreter which has the handler command for
+ * one or more reflected transforms records them in such a table, so that we
+ * are able to find them during interpreter/thread cleanup even if the actual
+ * channel they belong to was moved to a different interpreter and/or thread.
+ *
+ * The table is reachable via the standard interpreter AssocData, the key is
+ * defined below.
+ */
+
+typedef struct {
+ Tcl_HashTable map;
+} ReflectedTransformMap;
+
+#define RTMKEY "ReflectedTransformMap"
+
+/*
+ * Method literals. ==================================================
+ */
+
+static const char *const methodNames[] = {
+ "clear", /* OPT */
+ "drain", /* OPT, drain => read */
+ "finalize", /* */
+ "flush", /* OPT, flush => write */
+ "initialize", /* */
+ "limit?", /* OPT */
+ "read", /* OPT */
+ "write", /* OPT */
+ NULL
+};
+typedef enum {
+ METH_CLEAR,
+ METH_DRAIN,
+ METH_FINAL,
+ METH_FLUSH,
+ METH_INIT,
+ METH_LIMIT,
+ METH_READ,
+ METH_WRITE
+} MethodName;
+
+#define FLAG(m) (1 << (m))
+#define REQUIRED_METHODS \
+ (FLAG(METH_INIT) | FLAG(METH_FINAL))
+#define RANDW \
+ (TCL_READABLE | TCL_WRITABLE)
+
+#define IMPLIES(a,b) ((!(a)) || (b))
+#define NEGIMPL(a,b)
+#define HAS(x,f) (x & FLAG(f))
+
+#ifdef TCL_THREADS
+/*
+ * Thread specific types and structures.
+ *
+ * We are here essentially creating a very specific implementation of 'thread
+ * send'.
+ */
+
+/*
+ * Enumeration of all operations which can be forwarded.
+ */
+
+typedef enum {
+ ForwardedClear,
+ ForwardedClose,
+ ForwardedDrain,
+ ForwardedFlush,
+ ForwardedInput,
+ ForwardedLimit,
+ ForwardedOutput
+} ForwardedOperation;
+
+/*
+ * Event used to forward driver invocations to the thread actually managing
+ * the channel. We cannot construct the command to execute and forward that.
+ * Because then it will contain a mixture of Tcl_Obj's belonging to both the
+ * command handler thread (CT), and the thread managing the channel (MT),
+ * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we
+ * forward an operation code, the argument details, and reference to results.
+ * The command is assembled in the CT and belongs fully to that thread. No
+ * sharing problems.
+ */
+
+typedef struct ForwardParamBase {
+ int code; /* O: Ok/Fail of the cmd handler */
+ char *msgStr; /* O: Error message for handler failure */
+ int mustFree; /* O: True if msgStr is allocated, false if
+ * otherwise (static). */
+} ForwardParamBase;
+
+/*
+ * Operation specific parameter/result structures. (These are "subtypes" of
+ * ForwardParamBase. Where an operation does not need any special types, it
+ * has no "subtype" and just uses ForwardParamBase, as listed above.)
+ */
+
+struct ForwardParamTransform {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ char *buf; /* I: Bytes to transform,
+ * O: Bytes in transform result */
+ int size; /* I: #bytes to transform,
+ * O: #bytes in the transform result */
+};
+struct ForwardParamLimit {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ int max; /* O: Character read limit */
+};
+
+/*
+ * Now join all these together in a single union for convenience.
+ */
+
+typedef union ForwardParam {
+ ForwardParamBase base;
+ struct ForwardParamTransform transform;
+ struct ForwardParamLimit limit;
+} ForwardParam;
+
+/*
+ * Forward declaration.
+ */
+
+typedef struct ForwardingResult ForwardingResult;
+
+/*
+ * General event structure, with reference to operation specific data.
+ */
+
+typedef struct ForwardingEvent {
+ Tcl_Event event; /* Basic event data, has to be first item */
+ ForwardingResult *resultPtr;
+ ForwardedOperation op; /* Forwarded driver operation */
+ ReflectedTransform *rtPtr; /* Channel instance */
+ ForwardParam *param; /* Packaged arguments and return values, a
+ * ForwardParam pointer. */
+} ForwardingEvent;
+
+/*
+ * Structure to manage the result of the forwarding. This is not the result of
+ * the operation itself, but about the success of the forward event itself.
+ * The event can be successful, even if the operation which was forwarded
+ * failed. It is also there to manage the synchronization between the involved
+ * threads.
+ */
+
+struct ForwardingResult {
+ Tcl_ThreadId src; /* Originating thread. */
+ Tcl_ThreadId dst; /* Thread the op was forwarded to. */
+ Tcl_Interp *dsti; /* Interpreter in the thread the op was
+ * forwarded to. */
+ Tcl_Condition done; /* Condition variable the forwarder blocks
+ * on. */
+ int result; /* TCL_OK or TCL_ERROR */
+ ForwardingEvent *evPtr; /* Event the result belongs to. */
+ ForwardingResult *prevPtr, *nextPtr;
+ /* Links into the list of pending forwarded
+ * results. */
+};
+
+typedef struct ThreadSpecificData {
+ /*
+ * Table of all reflected transformations owned by this thread.
+ */
+
+ ReflectedTransformMap *rtmPtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * List of forwarded operations which have not completed yet, plus the mutex
+ * to protect the access to this process global list.
+ */
+
+static ForwardingResult *forwardList = NULL;
+TCL_DECLARE_MUTEX(rtForwardMutex)
+
+/*
+ * Function containing the generic code executing a forward, and wrapper
+ * macros for the actual operations we wish to forward. Uses ForwardProc as
+ * the event function executed by the thread receiving a forwarding event
+ * (which executes the appropriate function and collects the result, if any).
+ *
+ * The two ExitProcs are handlers so that things do not deadlock when either
+ * thread involved in the forwarding exits. They also clean things up so that
+ * we don't leak resources when threads go away.
+ */
+
+static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
+ ForwardedOperation op, const void *param);
+static int ForwardProc(Tcl_Event *evPtr, int mask);
+static void SrcExitProc(ClientData clientData);
+
+#define FreeReceivedError(p) \
+ if ((p)->base.mustFree) { \
+ ckfree((p)->base.msgStr); \
+ }
+#define PassReceivedErrorInterp(i,p) \
+ if ((i) != NULL) { \
+ Tcl_SetChannelErrorInterp((i), \
+ Tcl_NewStringObj((p)->base.msgStr, -1)); \
+ } \
+ FreeReceivedError(p)
+#define PassReceivedError(c,p) \
+ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
+ FreeReceivedError(p)
+#define ForwardSetStaticError(p,emsg) \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 0; \
+ (p)->base.msgStr = (char *) (emsg)
+#define ForwardSetDynamicError(p,emsg) \
+ (p)->base.code = TCL_ERROR; \
+ (p)->base.mustFree = 1; \
+ (p)->base.msgStr = (char *) (emsg)
+
+static void ForwardSetObjError(ForwardParam *p,
+ Tcl_Obj *objPtr);
+
+static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
+static void DeleteThreadReflectedTransformMap(ClientData clientData);
+
+#endif /* TCL_THREADS */
+
+#define SetChannelErrorStr(c,msgStr) \
+ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1))
+
+static Tcl_Obj * MarshallError(Tcl_Interp *interp);
+static void UnmarshallErrorResult(Tcl_Interp *interp,
+ Tcl_Obj *msgObj);
+
+/*
+ * Static functions for this file:
+ */
+
+static Tcl_Obj * DecodeEventMask(int mask);
+static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp,
+ Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj,
+ Tcl_Channel parentChan);
+static Tcl_Obj * NextHandle(void);
+static void FreeReflectedTransform(ReflectedTransform *rtPtr);
+static int InvokeTclMethod(ReflectedTransform *rtPtr,
+ const char *method, Tcl_Obj *argOneObj,
+ Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
+
+static ReflectedTransformMap * GetReflectedTransformMap(Tcl_Interp *interp);
+static void DeleteReflectedTransformMap(ClientData clientData,
+ Tcl_Interp *interp);
+
+/*
+ * Global constant strings (messages). ==================
+ * These string are used directly as bypass errors, thus they have to be valid
+ * Tcl lists where the last element is the message itself. Hence the
+ * list-quoting to keep the words of the message together. See also [x].
+ */
+
+static const char *msg_read_unsup = "{read not supported by Tcl driver}";
+static const char *msg_write_unsup = "{write not supported by Tcl driver}";
+#ifdef TCL_THREADS
+static const char *msg_send_originlost = "{Channel thread lost}";
+static const char *msg_send_dstlost = "{Owner lost}";
+#endif /* TCL_THREADS */
+static const char *msg_dstlost =
+ "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";
+
+/*
+ * Timer management (flushing out buffered data via artificial events).
+ */
+
+/*
+ * Number of milliseconds to wait before firing an event to try to flush out
+ * information waiting in buffers (fileevent support).
+ */
+
+#define FLUSH_DELAY (5)
+
+/*
+ * Helper functions encapsulating some of the thread forwarding to make the
+ * control flow in callers easier.
+ */
+
+static void TimerKill(ReflectedTransform *rtPtr);
+static void TimerSetup(ReflectedTransform *rtPtr);
+static void TimerRun(ClientData clientData);
+static int TransformRead(ReflectedTransform *rtPtr,
+ int *errorCodePtr, unsigned char *buf,
+ int toRead);
+static int TransformWrite(ReflectedTransform *rtPtr,
+ int *errorCodePtr, unsigned char *buf,
+ int toWrite);
+static int TransformDrain(ReflectedTransform *rtPtr,
+ int *errorCodePtr);
+static int TransformFlush(ReflectedTransform *rtPtr,
+ int *errorCodePtr, int op);
+static void TransformClear(ReflectedTransform *rtPtr);
+static int TransformLimit(ReflectedTransform *rtPtr,
+ int *errorCodePtr, int *maxPtr);
+
+/*
+ * Operation codes for TransformFlush().
+ */
+
+#define FLUSH_WRITE 1
+#define FLUSH_DISCARD 0
+
+/*
+ * Main methods to plug into the 'chan' ensemble'. ==================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanPushObjCmd --
+ *
+ * This function is invoked to process the "chan push" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result. The handle of the new channel is placed in the
+ * interp result.
+ *
+ * Side effects:
+ * Creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChanPushObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ ReflectedTransform *rtPtr; /* Instance data of the new (transform)
+ * channel. */
+ Tcl_Obj *chanObj; /* Handle of parent channel */
+ Tcl_Channel parentChan; /* Token of parent channel */
+ int mode; /* R/W mode of parent, later the new channel.
+ * Has to match the abilities of the handler
+ * commands */
+ Tcl_Obj *cmdObj; /* Command prefix, list of words */
+ Tcl_Obj *cmdNameObj; /* Command name */
+ Tcl_Obj *rtId; /* Handle of the new transform (channel) */
+ Tcl_Obj *modeObj; /* mode in obj form for method call */
+ int listc; /* Result of 'initialize', and of */
+ Tcl_Obj **listv; /* its sublist in the 2nd element */
+ int methIndex; /* Encoded method name */
+ int result; /* Result code for 'initialize' */
+ Tcl_Obj *resObj; /* Result data for 'initialize' */
+ int methods; /* Bitmask for supported methods. */
+ Tcl_Obj *err; /* Error message */
+ ReflectedTransformMap *rtmPtr;
+ /* Map of reflected transforms with handlers
+ * in this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
+ int isNew; /* Placeholder. */
+
+ /*
+ * Syntax: chan push CHANNEL CMDPREFIX
+ * [0] [1] [2] [3]
+ *
+ * Actually: rPush CHANNEL CMDPREFIX
+ * [0] [1] [2]
+ */
+
+#define CHAN (1)
+#define CMD (2)
+
+ /*
+ * Number of arguments...
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel cmdprefix");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First argument is a channel handle.
+ */
+
+ chanObj = objv[CHAN];
+ parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode);
+ if (parentChan == NULL) {
+ return TCL_ERROR;
+ }
+ parentChan = Tcl_GetTopChannel(parentChan);
+
+ /*
+ * Second argument is command prefix, i.e. list of words, first word is
+ * name of handler command, other words are fixed arguments. Run the
+ * 'initialize' method to get the list of supported methods. Validate
+ * this.
+ */
+
+ cmdObj = objv[CMD];
+
+ /*
+ * Basic check that the command prefix truly is a list.
+ */
+
+ if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now create the transformation (channel).
+ */
+
+ rtId = NextHandle();
+ rtPtr = NewReflectedTransform(interp, cmdObj, mode, rtId, parentChan);
+
+ /*
+ * Invoke 'initialize' and validate that the handler is present and ok.
+ * Squash the transformation if not.
+ */
+
+ modeObj = DecodeEventMask(mode);
+ /* assert modeObj.refCount == 1 */
+ result = InvokeTclMethod(rtPtr, "initialize", modeObj, NULL, &resObj);
+ Tcl_DecrRefCount(modeObj);
+ if (result != TCL_OK) {
+ UnmarshallErrorResult(interp, resObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ goto error;
+ }
+
+ /*
+ * Verify the result.
+ * - List, of method names. Convert to mask. Check for non-optionals
+ * through the mask. Compare open mode against optional r/w.
+ */
+
+ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
+ Tcl_AppendObjToObj(err, resObj);
+ Tcl_SetObjResult(interp, err);
+ Tcl_DecrRefCount(resObj);
+ goto error;
+ }
+
+ methods = 0;
+ while (listc > 0) {
+ if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
+ "method", TCL_EXACT, &methIndex) != TCL_OK) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, " initialize\" returned ", -1);
+ Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp));
+ Tcl_SetObjResult(interp, err);
+ Tcl_DecrRefCount(resObj);
+ goto error;
+ }
+
+ methods |= FLAG(methIndex);
+ listc--;
+ }
+ Tcl_DecrRefCount(resObj);
+
+ if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" does not support all required methods", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ /*
+ * Mode tell us what the parent channel supports. The methods tell us what
+ * the handler supports. We remove the non-supported bits from the mode
+ * and check that the channel is not completely inacessible. Afterward the
+ * mode tells us which methods are still required, and these methods will
+ * also be supported by the handler, by design of the check.
+ */
+
+ if (!HAS(methods, METH_READ)) {
+ mode &= ~TCL_READABLE;
+ }
+ if (!HAS(methods, METH_WRITE)) {
+ mode &= ~TCL_WRITABLE;
+ }
+
+ if (!mode) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" makes the channel inacessible", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ /*
+ * The mode and support for it is ok, now check the internal constraints.
+ */
+
+ if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ Tcl_ResetResult(interp);
+
+ /*
+ * Everything is fine now.
+ */
+
+ rtPtr->methods = methods;
+ rtPtr->mode = mode;
+ rtPtr->chan = Tcl_StackChannel(interp, &tclRTransformType, rtPtr, mode,
+ rtPtr->parent);
+
+ /*
+ * Register the transform in our our map for proper handling of deleted
+ * interpreters and/or threads.
+ */
+
+ rtmPtr = GetReflectedTransformMap(interp);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
+ Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
+ }
+ Tcl_SetHashValue(hPtr, rtPtr);
+#ifdef TCL_THREADS
+ rtmPtr = GetThreadReflectedTransformMap();
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ Tcl_SetHashValue(hPtr, rtPtr);
+#endif
+
+ /*
+ * Return the channel as the result of the command.
+ */
+
+ Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL);
+ return TCL_OK;
+
+ error:
+ /*
+ * We are not going through ReflectClose as we never had a channel
+ * structure.
+ */
+
+ Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ return TCL_ERROR;
+
+#undef CHAN
+#undef CMD
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanPopObjCmd --
+ *
+ * This function is invoked to process the "chan pop" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Posts events to a reflected channel, invokes event handlers. The
+ * latter implies that arbitrary side effects are possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChanPopObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ /*
+ * Syntax: chan pop CHANNEL
+ * [0] [1] [2]
+ *
+ * Actually: rPop CHANNEL
+ * [0] [1]
+ */
+
+#define CHAN (1)
+
+ const char *chanId; /* Tcl level channel handle */
+ Tcl_Channel chan; /* Channel associated to the handle */
+ int mode; /* Channel r/w mode */
+
+ /*
+ * Number of arguments...
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First argument is a channel, which may have a (reflected)
+ * transformation.
+ */
+
+ chanId = TclGetString(objv[CHAN]);
+ chan = Tcl_GetChannel(interp, chanId, &mode);
+
+ if (chan == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Removing transformations is generic, and not restricted to reflected
+ * transformations.
+ */
+
+ Tcl_UnstackChannel(interp, chan);
+ return TCL_OK;
+
+#undef CHAN
+}
+
+/*
+ * Channel error message marshalling utilities.
+ */
+
+static Tcl_Obj *
+MarshallError(
+ Tcl_Interp *interp)
+{
+ /*
+ * Capture the result status of the interpreter into a string. => List of
+ * options and values, followed by the error message. The result has
+ * refCount 0.
+ */
+
+ Tcl_Obj *returnOpt = Tcl_GetReturnOptions(interp, TCL_ERROR);
+
+ /*
+ * => returnOpt.refCount == 0. We can append directly.
+ */
+
+ Tcl_ListObjAppendElement(NULL, returnOpt, Tcl_GetObjResult(interp));
+ return returnOpt;
+}
+
+static void
+UnmarshallErrorResult(
+ Tcl_Interp *interp,
+ Tcl_Obj *msgObj)
+{
+ int lc;
+ Tcl_Obj **lv;
+ int explicitResult;
+ int numOptions;
+
+ /*
+ * Process the caught message.
+ *
+ * Syntax = (option value)... ?message?
+ *
+ * Bad syntax causes a panic. This is OK because the other side uses
+ * Tcl_GetReturnOptions and list construction functions to marshall the
+ * information; if we panic here, something has gone badly wrong already.
+ */
+
+ if (Tcl_ListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
+ Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
+ }
+ if (interp == NULL) {
+ return;
+ }
+
+ explicitResult = lc & 1; /* Odd number of values? */
+ numOptions = lc - explicitResult;
+
+ if (explicitResult) {
+ Tcl_SetObjResult(interp, lv[lc-1]);
+ }
+
+ Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
+ ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED;
+}
+
+/*
+ * Driver functions. ================================================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectClose --
+ *
+ * This function is invoked when the channel is closed, to delete the
+ * driver specific instance data.
+ *
+ * Results:
+ * A posix error.
+ *
+ * Side effects:
+ * Releases memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectClose(
+ ClientData clientData,
+ Tcl_Interp *interp)
+{
+ ReflectedTransform *rtPtr = clientData;
+ int result; /* Result code for 'close' */
+ Tcl_Obj *resObj; /* Result data for 'close' */
+ ReflectedTransformMap *rtmPtr;
+ /* Map of reflected transforms with handlers
+ * in this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
+
+ if (TclInThreadExit()) {
+ /*
+ * This call comes from TclFinalizeIOSystem. There are no
+ * interpreters, and therefore we cannot call upon the handler command
+ * anymore. Threading is irrelevant as well. We simply clean up all
+ * our C level data structures and leave the Tcl level to the other
+ * finalization functions.
+ */
+
+ /*
+ * THREADED => Forward this to the origin thread
+ *
+ * Note: DeleteThreadReflectedTransformMap() is the thread exit handler
+ * for the origin thread. Use this to clean up the structure? Except
+ * if lost?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
+ result = p.base.code;
+
+ /*
+ * FreeReflectedTransform is done in the forwarded operation!, in
+ * the other thread. rtPtr here is gone!
+ */
+
+ if (result != TCL_OK) {
+ FreeReceivedError(&p);
+ }
+ return EOK;
+ }
+#endif
+
+ Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ return EOK;
+ }
+
+ /*
+ * In the reflected channel implementation a cleaned method mask here
+ * implies that the channel creation was aborted, and "finalize" must not
+ * be called. for transformations however we are not going through here on
+ * such an abort, but directly through FreeReflectedTransform. So for us
+ * that check is not necessary. We always go through 'finalize'.
+ */
+
+ if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
+ int errorCode;
+
+ if (!TransformDrain(rtPtr, &errorCode)) {
+ return errorCode;
+ }
+ }
+
+ if (HAS(rtPtr->methods, METH_FLUSH)) {
+ int errorCode;
+
+ if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
+ return errorCode;
+ }
+ }
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
+ result = p.base.code;
+
+ /*
+ * FreeReflectedTransform is done in the forwarded operation!, in the
+ * other thread. rtPtr here is gone!
+ */
+
+ if (result != TCL_OK) {
+ PassReceivedErrorInterp(interp, &p);
+ return EINVAL;
+ }
+ return EOK;
+ }
+#endif
+
+ /*
+ * Do the actual invokation of "finalize" now; we're in the right thread.
+ */
+
+ result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
+ if ((result != TCL_OK) && (interp != NULL)) {
+ Tcl_SetChannelErrorInterp(interp, resObj);
+ }
+
+ Tcl_DecrRefCount(resObj); /* Remove reference we held from the
+ * invoke. */
+
+ /*
+ * Remove the transform from the map before releasing the memory, to
+ * prevent future accesses from finding and dereferencing a dangling
+ * pointer.
+ *
+ * NOTE: The transform may not be in the map. This is ok, that happens
+ * when the transform was created in a different interpreter and/or thread
+ * and then was moved here.
+ *
+ * NOTE: The channel may have been removed from the map already via
+ * the per-interp DeleteReflectedTransformMap exit-handler.
+ */
+
+ if (rtPtr->interp) {
+ rtmPtr = GetReflectedTransformMap(rtPtr->interp);
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+
+ /*
+ * In a threaded interpreter we manage a per-thread map as well, to allow
+ * us to survive if the script level pulls the rug out under a channel by
+ * deleting the owning thread.
+ */
+
+#ifdef TCL_THREADS
+ rtmPtr = GetThreadReflectedTransformMap();
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+#endif
+
+ Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ return (result == TCL_OK) ? EOK : EINVAL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectInput --
+ *
+ * This function is invoked when more data is requested from the channel.
+ *
+ * Results:
+ * The number of bytes read.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectInput(
+ ClientData clientData,
+ char *buf,
+ int toRead,
+ int *errorCodePtr)
+{
+ ReflectedTransform *rtPtr = clientData;
+ int gotBytes, copied, readBytes;
+
+ /*
+ * The following check can be done before thread redirection, because we
+ * are reading from an item which is readonly, i.e. will never change
+ * during the lifetime of the channel.
+ */
+
+ if (!(rtPtr->methods & FLAG(METH_READ))) {
+ SetChannelErrorStr(rtPtr->chan, msg_read_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ Tcl_Preserve(rtPtr);
+
+ gotBytes = 0;
+ while (toRead > 0) {
+ /*
+ * Loop until the request is satisfied (or no data available from
+ * below, possibly EOF).
+ */
+
+ copied = ResultCopy(&rtPtr->result, UCHARP(buf), toRead);
+ toRead -= copied;
+ buf += copied;
+ gotBytes += copied;
+
+ if (toRead == 0) {
+ goto stop;
+ }
+
+ /*
+ * The buffer is exhausted, but the caller wants even more. We now
+ * have to go to the underlying channel, get more bytes and then
+ * transform them for delivery. We may not get what we want (full EOF
+ * or temporarily out of data).
+ *
+ * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target
+ * to store the intermediary information read from the parent channel.
+ *
+ * Ask the transform how much data it allows us to read from the
+ * underlying channel. This feature allows the transform to signal EOF
+ * upstream although there is none downstream. Useful to control an
+ * unbounded 'fcopy' for example, either through counting bytes, or by
+ * pattern matching.
+ */
+
+ if ((rtPtr->methods & FLAG(METH_LIMIT))) {
+ int maxRead = -1;
+
+ if (!TransformLimit(rtPtr, errorCodePtr, &maxRead)) {
+ goto error;
+ }
+ if (maxRead == 0) {
+ goto stop;
+ } else if (maxRead > 0) {
+ if (maxRead < toRead) {
+ toRead = maxRead;
+ }
+ } /* else: 'maxRead < 0' == Accept the current value of toRead */
+ }
+
+ if (toRead <= 0) {
+ goto stop;
+ }
+
+ readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead);
+ if (readBytes < 0) {
+ /*
+ * Report errors to caller. The state of the seek system is
+ * unchanged!
+ */
+
+ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
+ /*
+ * EAGAIN is a special situation. If we had some data before
+ * we report that instead of the request to re-try.
+ */
+
+ goto stop;
+ }
+
+ *errorCodePtr = Tcl_GetErrno();
+ goto error;
+ }
+
+ if (readBytes == 0) {
+ /*
+ * Check wether we hit on EOF in 'parent' or not. If not
+ * differentiate between blocking and non-blocking modes. In
+ * non-blocking mode we ran temporarily out of data. Signal this
+ * to the caller via EWOULDBLOCK and error return (-1). In the
+ * other cases we simply return what we got and let the caller
+ * wait for more. On the other hand, if we got an EOF we have to
+ * convert and flush all waiting partial data.
+ */
+
+ if (!Tcl_Eof(rtPtr->parent)) {
+ /*
+ * The state of the seek system is unchanged!
+ */
+
+ if ((gotBytes == 0) && rtPtr->nonblocking) {
+ *errorCodePtr = EWOULDBLOCK;
+ goto error;
+ }
+ goto stop;
+ } else {
+ /*
+ * Eof in parent.
+ */
+
+ if (rtPtr->readIsDrained) {
+ goto stop;
+ }
+
+ /*
+ * Now this is a bit different. The partial data waiting is
+ * converted and returned.
+ */
+
+ if (HAS(rtPtr->methods, METH_DRAIN)) {
+ if (!TransformDrain(rtPtr, errorCodePtr)) {
+ goto error;
+ }
+ }
+
+ if (ResultLength(&rtPtr->result) == 0) {
+ /*
+ * The drain delivered nothing.
+ */
+
+ goto stop;
+ }
+
+ /*
+ * Reset eof, force caller to drain result buffer.
+ */
+
+ ((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF;
+ continue; /* at: while (toRead > 0) */
+ }
+ } /* readBytes == 0 */
+
+ /*
+ * Transform the read chunk, which was not empty. Anything we got back
+ * is a transformation result is put into our buffers, and the next
+ * iteration will put it into the result.
+ */
+
+ if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) {
+ goto error;
+ }
+ } /* while toRead > 0 */
+
+ stop:
+ Tcl_Release(rtPtr);
+ return gotBytes;
+
+ error:
+ gotBytes = -1;
+ goto stop;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectOutput --
+ *
+ * This function is invoked when data is writen to the channel.
+ *
+ * Results:
+ * The number of bytes actually written.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectOutput(
+ ClientData clientData,
+ const char *buf,
+ int toWrite,
+ int *errorCodePtr)
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * The following check can be done before thread redirection, because we
+ * are reading from an item which is readonly, i.e. will never change
+ * during the lifetime of the channel.
+ */
+
+ if (!(rtPtr->methods & FLAG(METH_WRITE))) {
+ SetChannelErrorStr(rtPtr->chan, msg_write_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ if (toWrite == 0) {
+ /*
+ * Nothing came in to write, ignore the call
+ */
+
+ return 0;
+ }
+
+ /*
+ * Discard partial data in the input buffers, i.e. on the read side. Like
+ * we do when explicitly seeking as well.
+ */
+
+ Tcl_Preserve(rtPtr);
+
+ if ((rtPtr->methods & FLAG(METH_CLEAR))) {
+ TransformClear(rtPtr);
+ }
+
+ /*
+ * Hand the data to the transformation itself. Anything it deigned to
+ * return to us is a (partial) transformation result and written to the
+ * parent channel for further processing.
+ */
+
+ if (!TransformWrite(rtPtr, errorCodePtr, UCHARP(buf), toWrite)) {
+ Tcl_Release(rtPtr);
+ return -1;
+ }
+
+ *errorCodePtr = EOK;
+ Tcl_Release(rtPtr);
+ return toWrite;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectSeekWide / ReflectSeek --
+ *
+ * This function is invoked when the user wishes to seek on the channel.
+ *
+ * Results:
+ * The new location of the access point.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, per the parent channel, and the called
+ * scripts.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+ReflectSeekWide(
+ ClientData clientData,
+ Tcl_WideInt offset,
+ int seekMode,
+ int *errorCodePtr)
+{
+ ReflectedTransform *rtPtr = clientData;
+ Channel *parent = (Channel *) rtPtr->parent;
+ Tcl_WideInt curPos; /* Position on the device. */
+
+ Tcl_DriverSeekProc *seekProc =
+ Tcl_ChannelSeekProc(Tcl_GetChannelType(rtPtr->parent));
+
+ /*
+ * Fail if the parent channel is not seekable.
+ */
+
+ if (seekProc == NULL) {
+ Tcl_SetErrno(EINVAL);
+ return Tcl_LongAsWide(-1);
+ }
+
+ /*
+ * Check if we can leave out involving the Tcl level, i.e. transformation
+ * handler. This is true for tell requests, and transformations which
+ * support neither flush, nor drain. For these cases we can pass the
+ * request down and the result back up unchanged.
+ */
+
+ Tcl_Preserve(rtPtr);
+
+ if (((seekMode != SEEK_CUR) || (offset != 0))
+ && (HAS(rtPtr->methods, METH_CLEAR)
+ || HAS(rtPtr->methods, METH_FLUSH))) {
+ /*
+ * Neither a tell request, nor clear/flush both not supported. We have
+ * to go through the Tcl level to clear and/or flush the
+ * transformation.
+ */
+
+ if ((rtPtr->methods & FLAG(METH_CLEAR))) {
+ TransformClear(rtPtr);
+ }
+
+ /*
+ * When flushing the transform for seeking the generated results are
+ * irrelevant. We cannot put them into the channel, this would move
+ * the location, throwing it off with regard to where we are and are
+ * seeking to.
+ */
+
+ if (HAS(rtPtr->methods, METH_FLUSH)) {
+ if (!TransformFlush(rtPtr, errorCodePtr, FLUSH_DISCARD)) {
+ Tcl_Release(rtPtr);
+ return -1;
+ }
+ }
+ }
+
+ /*
+ * Now seek to the new position in the channel as requested by the
+ * caller. Note that we prefer the wideSeekProc if that is available and
+ * non-NULL...
+ */
+
+ if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) &&
+ parent->typePtr->wideSeekProc != NULL) {
+ curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset,
+ seekMode, errorCodePtr);
+ } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
+ offset > Tcl_LongAsWide(LONG_MAX)) {
+ *errorCodePtr = EOVERFLOW;
+ curPos = Tcl_LongAsWide(-1);
+ } else {
+ curPos = Tcl_LongAsWide(parent->typePtr->seekProc(
+ parent->instanceData, Tcl_WideAsLong(offset), seekMode,
+ errorCodePtr));
+ }
+ if (curPos == Tcl_LongAsWide(-1)) {
+ Tcl_SetErrno(*errorCodePtr);
+ }
+
+ *errorCodePtr = EOK;
+ Tcl_Release(rtPtr);
+ return curPos;
+}
+
+static int
+ReflectSeek(
+ ClientData clientData,
+ long offset,
+ int seekMode,
+ int *errorCodePtr)
+{
+ /*
+ * This function can be invoked from a transformation which is based on
+ * standard seeking, i.e. non-wide. Because of this we have to implement
+ * it, a dummy is not enough. We simply delegate the call to the wide
+ * routine.
+ */
+
+ return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ errorCodePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectWatch --
+ *
+ * This function is invoked to tell the channel what events the I/O
+ * system is interested in.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ReflectWatch(
+ ClientData clientData,
+ int mask)
+{
+ ReflectedTransform *rtPtr = clientData;
+ Tcl_DriverWatchProc *watchProc;
+
+ watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(rtPtr->parent));
+ watchProc(Tcl_GetChannelInstanceData(rtPtr->parent), mask);
+
+ /*
+ * Management of the internal timer.
+ */
+
+ if (!(mask & TCL_READABLE) || (ResultLength(&rtPtr->result) == 0)) {
+ /*
+ * A pending timer may exist, but either is there no (more) interest
+ * in the events it generates or nothing is available for reading.
+ * Remove it, if existing.
+ */
+
+ TimerKill(rtPtr);
+ } else {
+ /*
+ * There might be no pending timer, but there is interest in readable
+ * events and we actually have data waiting, so generate a timer to
+ * flush that if it does not exist.
+ */
+
+ TimerSetup(rtPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectBlock --
+ *
+ * This function is invoked to tell the channel which blocking behaviour
+ * is required of it.
+ *
+ * Results:
+ * A posix error number.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectBlock(
+ ClientData clientData,
+ int nonblocking)
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * Transformations simply record the blocking mode in their C level
+ * structure for use by --> ReflectInput. The Tcl level doesn't see this
+ * information or change. As such thread forwarding is not required.
+ */
+
+ rtPtr->nonblocking = nonblocking;
+ return EOK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectSetOption --
+ *
+ * This function is invoked to configure a channel option.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, per the parent channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectSetOption(
+ ClientData clientData, /* Channel to query */
+ Tcl_Interp *interp, /* Interpreter to leave error messages in */
+ const char *optionName, /* Name of requested option */
+ const char *newValue) /* The new value */
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * Transformations have no options. Thus the call is passed down unchanged
+ * to the parent channel for processing. Its results are passed back
+ * unchanged as well. This all happens in the thread we are in. As the Tcl
+ * level is not involved there is no need for thread forwarding.
+ */
+
+ Tcl_DriverSetOptionProc *setOptionProc =
+ Tcl_ChannelSetOptionProc(Tcl_GetChannelType(rtPtr->parent));
+
+ if (setOptionProc == NULL) {
+ return TCL_ERROR;
+ }
+ return setOptionProc(Tcl_GetChannelInstanceData(rtPtr->parent), interp,
+ optionName, newValue);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectGetOption --
+ *
+ * This function is invoked to retrieve all or a channel options.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, per the parent channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectGetOption(
+ ClientData clientData, /* Channel to query */
+ Tcl_Interp *interp, /* Interpreter to leave error messages in */
+ const char *optionName, /* Name of reuqested option */
+ Tcl_DString *dsPtr) /* String to place the result into */
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * Transformations have no options. Thus the call is passed down unchanged
+ * to the parent channel for processing. Its results are passed back
+ * unchanged as well. This all happens in the thread we are in. As the Tcl
+ * level is not involved there is no need for thread forwarding.
+ *
+ * Note that the parent not having a driver for option retrieval is not an
+ * immediate error. A query for all options is ok. Only a request for a
+ * specific option has to fail.
+ */
+
+ Tcl_DriverGetOptionProc *getOptionProc =
+ Tcl_ChannelGetOptionProc(Tcl_GetChannelType(rtPtr->parent));
+
+ if (getOptionProc != NULL) {
+ return getOptionProc(Tcl_GetChannelInstanceData(rtPtr->parent),
+ interp, optionName, dsPtr);
+ } else if (optionName == NULL) {
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectHandle --
+ *
+ * This function is invoked to retrieve the associated file handle.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, per the parent channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectHandle(
+ ClientData clientData,
+ int direction,
+ ClientData *handlePtr)
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * Transformations have no handle of their own. As such we simply query
+ * the parent channel for it. This way the qery will ripple down through
+ * all transformations until reaches the base channel. Which then returns
+ * its handle, or fails. The former will then ripple up the stack.
+ *
+ * This all happens in the thread we are in. As the Tcl level is not
+ * involved no forwarding is required.
+ */
+
+ return Tcl_GetChannelHandle(rtPtr->parent, direction, handlePtr);
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectNotify --
+ *
+ * This function is invoked to reported incoming events.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, per the parent channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectNotify(
+ ClientData clientData,
+ int mask)
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ /*
+ * An event occured in the underlying channel.
+ *
+ * We delete our timer. It was not fired, yet we are here, so the channel
+ * below generated such an event and we don't have to. The renewal of the
+ * interest after the execution of channel handlers will eventually cause
+ * us to recreate the timer (in ReflectWatch).
+ */
+
+ TimerKill(rtPtr);
+
+ /*
+ * Pass to higher layers.
+ */
+
+ return mask;
+}
+
+/*
+ * Helpers. =========================================================
+ */
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DecodeEventMask --
+ *
+ * This function takes an internal bitmask of events and constructs the
+ * equivalent list of event items.
+ *
+ * Results:
+ * A Tcl_Obj reference. The object will have a refCount of one. The user
+ * has to decrement it to release the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ * DUPLICATE of 'DecodeEventMask' in tclIORChan.c
+ */
+
+static Tcl_Obj *
+DecodeEventMask(
+ int mask)
+{
+ register const char *eventStr;
+ Tcl_Obj *evObj;
+
+ switch (mask & RANDW) {
+ case RANDW:
+ eventStr = "read write";
+ break;
+ case TCL_READABLE:
+ eventStr = "read";
+ break;
+ case TCL_WRITABLE:
+ eventStr = "write";
+ break;
+ default:
+ eventStr = "";
+ break;
+ }
+
+ evObj = Tcl_NewStringObj(eventStr, -1);
+ Tcl_IncrRefCount(evObj);
+ return evObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewReflectedTransform --
+ *
+ * This function is invoked to allocate and initialize the instance data
+ * of a new reflected channel.
+ *
+ * Results:
+ * A heap-allocated channel instance.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ReflectedTransform *
+NewReflectedTransform(
+ Tcl_Interp *interp,
+ Tcl_Obj *cmdpfxObj,
+ int mode,
+ Tcl_Obj *handleObj,
+ Tcl_Channel parentChan)
+{
+ ReflectedTransform *rtPtr;
+ int listc;
+ Tcl_Obj **listv;
+ int i;
+
+ rtPtr = ckalloc(sizeof(ReflectedTransform));
+
+ /* rtPtr->chan: Assigned by caller. Dummy data here. */
+ /* rtPtr->methods: Assigned by caller. Dummy data here. */
+
+ rtPtr->chan = NULL;
+ rtPtr->methods = 0;
+#ifdef TCL_THREADS
+ rtPtr->thread = Tcl_GetCurrentThread();
+#endif
+ rtPtr->parent = parentChan;
+ rtPtr->interp = interp;
+ rtPtr->handle = handleObj;
+ Tcl_IncrRefCount(handleObj);
+ rtPtr->timer = NULL;
+ rtPtr->mode = 0;
+ rtPtr->readIsDrained = 0;
+ rtPtr->nonblocking =
+ (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING);
+
+ /*
+ * Query parent for current blocking mode.
+ */
+
+ ResultInit(&rtPtr->result);
+
+ /*
+ * Method placeholder.
+ */
+
+ /* ASSERT: cmdpfxObj is a Tcl List */
+
+ Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv);
+
+ /*
+ * See [==] as well.
+ * Storage for the command prefix and the additional words required for
+ * the invocation of methods in the command handler.
+ *
+ * listv [0] [listc-1] | [listc] [listc+1] |
+ * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
+ * cmd ... pfx | method chan | detail1 detail2
+ */
+
+ rtPtr->argc = listc + 2;
+ rtPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4));
+
+ /*
+ * Duplicate object references.
+ */
+
+ for (i=0; i<listc ; i++) {
+ Tcl_Obj *word = rtPtr->argv[i] = listv[i];
+
+ Tcl_IncrRefCount(word);
+ }
+
+ i++; /* Skip placeholder for method */
+
+ /*
+ * See [x] in FreeReflectedTransform for release
+ */
+ rtPtr->argv[i] = handleObj;
+ Tcl_IncrRefCount(handleObj);
+
+ /*
+ * The next two objects are kept empty, varying arguments.
+ */
+
+ /*
+ * Initialization complete.
+ */
+
+ return rtPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NextHandle --
+ *
+ * This function is invoked to generate a channel handle for a new
+ * reflected channel.
+ *
+ * Results:
+ * A Tcl_Obj containing the string of the new channel handle. The
+ * refcount of the returned object is -- zero --.
+ *
+ * Side effects:
+ * May allocate memory. Mutex protected critical section locks out other
+ * threads for a short time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+NextHandle(void)
+{
+ /*
+ * Count number of generated reflected channels. Used for id generation.
+ * Ids are never reclaimed and there is no dealing with wrap around. On
+ * the other hand, "unsigned long" should be big enough except for
+ * absolute longrunners (generate a 100 ids per second => overflow will
+ * occur in 1 1/3 years).
+ */
+
+ TCL_DECLARE_MUTEX(rtCounterMutex)
+ static unsigned long rtCounter = 0;
+ Tcl_Obj *resObj;
+
+ Tcl_MutexLock(&rtCounterMutex);
+ resObj = Tcl_ObjPrintf("rt%lu", rtCounter);
+ rtCounter++;
+ Tcl_MutexUnlock(&rtCounterMutex);
+
+ return resObj;
+}
+
+static void
+FreeReflectedTransform(
+ ReflectedTransform *rtPtr)
+{
+ int i, n;
+
+ TimerKill(rtPtr);
+ ResultClear(&rtPtr->result);
+
+ Tcl_DecrRefCount(rtPtr->handle);
+ rtPtr->handle = NULL;
+
+ n = rtPtr->argc - 2;
+ for (i=0; i<n; i++) {
+ Tcl_DecrRefCount(rtPtr->argv[i]);
+ }
+
+ /*
+ * See [x] in NewReflectedTransform for lock
+ * n+1 = argc-1.
+ */
+ Tcl_DecrRefCount(rtPtr->argv[n+1]);
+
+ ckfree(rtPtr->argv);
+ ckfree(rtPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InvokeTclMethod --
+ *
+ * This function is used to invoke the Tcl level of a reflected channel.
+ * It handles all the command assembly, invokation, and generic state and
+ * result mgmt. It does *not* handle thread redirection; that is the
+ * responsibility of clients of this function.
+ *
+ * Results:
+ * Result code and data as returned by the method.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ * Contract:
+ * argOneObj.refCount >= 1 on entry and exit, if argOneObj != NULL
+ * argTwoObj.refCount >= 1 on entry and exit, if argTwoObj != NULL
+ * resObj.refCount in {0, 1, ...}
+ *
+ *----------------------------------------------------------------------
+ * Semi-DUPLICATE of 'InvokeTclMethod' in tclIORChan.c
+ * - Semi because different structures are used.
+ * - Still possible to factor out the commonalities into a separate structure.
+ */
+
+static int
+InvokeTclMethod(
+ ReflectedTransform *rtPtr,
+ const char *method,
+ Tcl_Obj *argOneObj, /* NULL'able */
+ Tcl_Obj *argTwoObj, /* NULL'able */
+ Tcl_Obj **resultObjPtr) /* NULL'able */
+{
+ int cmdc; /* #words in constructed command */
+ Tcl_Obj *methObj = NULL; /* Method name in object form */
+ Tcl_InterpState sr; /* State of handler interp */
+ int result; /* Result code of method invokation */
+ Tcl_Obj *resObj = NULL; /* Result of method invokation. */
+
+ if (!rtPtr->interp) {
+ /*
+ * The transform is marked as dead. Bail out immediately, with an
+ * appropriate error.
+ */
+
+ if (resultObjPtr != NULL) {
+ resObj = Tcl_NewStringObj(msg_dstlost,-1);
+ *resultObjPtr = resObj;
+ Tcl_IncrRefCount(resObj);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * NOTE (5): Decide impl. issue: Cache objects with method names?
+ * Requires TSD data as reflections can be created in many different
+ * threads.
+ * NO: Caching of command resolutions means storage per channel.
+ */
+
+ /*
+ * Insert method into the pre-allocated area, after the command prefix,
+ * before the channel id.
+ */
+
+ methObj = Tcl_NewStringObj(method, -1);
+ Tcl_IncrRefCount(methObj);
+ rtPtr->argv[rtPtr->argc - 2] = methObj;
+
+ /*
+ * Append the additional argument containing method specific details
+ * behind the channel id. If specified.
+ *
+ * Because of the contract there is no need to increment the refcounts.
+ * The objects will survive the Tcl_EvalObjv without change.
+ */
+
+ cmdc = rtPtr->argc;
+ if (argOneObj) {
+ rtPtr->argv[cmdc] = argOneObj;
+ cmdc++;
+ if (argTwoObj) {
+ rtPtr->argv[cmdc] = argTwoObj;
+ cmdc++;
+ }
+ }
+
+ /*
+ * And run the handler... This is done in auch a manner which leaves any
+ * existing state intact.
+ */
+
+ sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
+ Tcl_Preserve(rtPtr);
+ result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);
+
+ /*
+ * We do not try to extract the result information if the caller has no
+ * interest in it. I.e. there is no need to put effort into creating
+ * something which is discarded immediately after.
+ */
+
+ if (resultObjPtr) {
+ if (result == TCL_OK) {
+ /*
+ * Ok result taken as is, also if the caller requests that there
+ * is no capture.
+ */
+
+ resObj = Tcl_GetObjResult(rtPtr->interp);
+ } else {
+ /*
+ * Non-ok result is always treated as an error. We have to capture
+ * the full state of the result, including additional options.
+ *
+ * This is complex and ugly, and would be completely unnecessary
+ * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
+ */
+ if (result != TCL_ERROR) {
+ Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
+ int cmdLen;
+ const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+
+ Tcl_IncrRefCount(cmd);
+ Tcl_ResetResult(rtPtr->interp);
+ Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf(
+ "chan handler returned bad code: %d", result));
+ Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen);
+ Tcl_DecrRefCount(cmd);
+ result = TCL_ERROR;
+ }
+ Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf(
+ "\n (chan handler subcommand \"%s\")", method));
+ resObj = MarshallError(rtPtr->interp);
+ }
+ Tcl_IncrRefCount(resObj);
+ }
+ Tcl_RestoreInterpState(rtPtr->interp, sr);
+ Tcl_Release(rtPtr);
+
+ /*
+ * Cleanup of the dynamic parts of the command.
+ *
+ * The detail objects survived the Tcl_EvalObjv without change because of
+ * the contract. Therefore there is no need to decrement the refcounts. Only
+ * the internal method object has to be disposed of.
+ */
+
+ Tcl_DecrRefCount(methObj);
+
+ /*
+ * The resObj has a ref count of 1 at this location. This means that the
+ * caller of InvokeTclMethod has to dispose of it (but only if it was
+ * returned to it).
+ */
+
+ if (resultObjPtr != NULL) {
+ *resultObjPtr = resObj;
+ }
+
+ /*
+ * There no need to handle the case where nothing is returned, because for
+ * that case resObj was not set anyway.
+ */
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetReflectedTransformMap --
+ *
+ * Gets and potentially initializes the reflected channel map for an
+ * interpreter.
+ *
+ * Results:
+ * A pointer to the map created, for use by the caller.
+ *
+ * Side effects:
+ * Initializes the reflected channel map for an interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ReflectedTransformMap *
+GetReflectedTransformMap(
+ Tcl_Interp *interp)
+{
+ ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);
+
+ if (rtmPtr == NULL) {
+ rtmPtr = ckalloc(sizeof(ReflectedTransformMap));
+ Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, RTMKEY,
+ (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
+ }
+ return rtmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteReflectedTransformMap --
+ *
+ * Deletes the channel table for an interpreter, closing any open
+ * channels whose refcount reaches zero. This procedure is invoked when
+ * an interpreter is deleted, via the AssocData cleanup mechanism.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deletes the hash table of channels. May close channels. May flush
+ * output on closed channels. Removes any channeEvent handlers that were
+ * registered in this interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteReflectedTransformMap(
+ ClientData clientData, /* The per-interpreter data structure. */
+ Tcl_Interp *interp) /* The interpreter being deleted. */
+{
+ ReflectedTransformMap *rtmPtr; /* The map */
+ Tcl_HashSearch hSearch; /* Search variable. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ ReflectedTransform *rtPtr;
+#ifdef TCL_THREADS
+ ForwardingResult *resultPtr;
+ ForwardingEvent *evPtr;
+ ForwardParam *paramPtr;
+#endif
+
+ /*
+ * Delete all entries. The channels may have been closed already, or will
+ * be closed later, by the standard IO finalization of an interpreter
+ * under destruction. Except for the channels which were moved to a
+ * different interpreter and/or thread. They do not exist from the IO
+ * systems point of view and will not get closed. Therefore mark all as
+ * dead so that any future access will cause a proper error. For channels
+ * in a different thread we actually do the same as
+ * DeleteThreadReflectedTransformMap(), just restricted to the channels of
+ * this interp.
+ */
+
+ rtmPtr = clientData;
+ for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
+ rtPtr = Tcl_GetHashValue(hPtr);
+ rtPtr->interp = NULL;
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&rtmPtr->map);
+ ckfree(&rtmPtr->map);
+
+#ifdef TCL_THREADS
+ /*
+ * The origin interpreter for one or more reflected channels is gone.
+ */
+
+ /*
+ * Go through the list of pending results and cancel all whose events were
+ * destined for this interpreter. While this is in progress we block any
+ * other access to the list of pending results.
+ */
+
+ Tcl_MutexLock(&rtForwardMutex);
+
+ for (resultPtr = forwardList; resultPtr != NULL;
+ resultPtr = resultPtr->nextPtr) {
+ if (resultPtr->dsti != interp) {
+ /*
+ * Ignore results/events for other interpreters.
+ */
+
+ continue;
+ }
+
+ /*
+ * The receiver for the event exited, before processing the event. We
+ * detach the result now, wake the originator up and signal failure.
+ */
+
+ evPtr = resultPtr->evPtr;
+ paramPtr = evPtr->param;
+
+ evPtr->resultPtr = NULL;
+ resultPtr->evPtr = NULL;
+ resultPtr->result = TCL_ERROR;
+
+ ForwardSetStaticError(paramPtr, msg_send_dstlost);
+
+ Tcl_ConditionNotify(&resultPtr->done);
+ }
+
+ /*
+ * Get the map of all channels handled by the current thread. This is a
+ * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
+ * through the channels and remove all which were handled by this
+ * interpreter. They have already been marked as dead.
+ */
+
+ rtmPtr = GetThreadReflectedTransformMap();
+ for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ rtPtr = Tcl_GetHashValue(hPtr);
+
+ if (rtPtr->interp != interp) {
+ /*
+ * Ignore entries for other interpreters.
+ */
+
+ continue;
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ Tcl_MutexUnlock(&rtForwardMutex);
+#endif
+}
+
+#ifdef TCL_THREADS
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetThreadReflectedTransformMap --
+ *
+ * Gets and potentially initializes the reflected channel map for a
+ * thread.
+ *
+ * Results:
+ * A pointer to the map created, for use by the caller.
+ *
+ * Side effects:
+ * Initializes the reflected channel map for a thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ReflectedTransformMap *
+GetThreadReflectedTransformMap(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!tsdPtr->rtmPtr) {
+ tsdPtr->rtmPtr = ckalloc(sizeof(ReflectedTransformMap));
+ Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
+ Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
+ }
+
+ return tsdPtr->rtmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteThreadReflectedTransformMap --
+ *
+ * Deletes the channel table for a thread. This procedure is invoked when
+ * a thread is deleted. The channels have already been marked as dead, in
+ * DeleteReflectedTransformMap().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deletes the hash table of channels.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteThreadReflectedTransformMap(
+ ClientData clientData) /* The per-thread data structure. */
+{
+ Tcl_HashSearch hSearch; /* Search variable. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
+ ReflectedTransformMap *rtmPtr; /* The map */
+ ForwardingResult *resultPtr;
+
+ /*
+ * The origin thread for one or more reflected channels is gone.
+ * NOTE: If this function is called due to a thread getting killed the
+ * per-interp DeleteReflectedTransformMap is apparently not called.
+ */
+
+ /*
+ * Go through the list of pending results and cancel all whose events were
+ * destined for this thread. While this is in progress we block any
+ * other access to the list of pending results.
+ */
+
+ Tcl_MutexLock(&rtForwardMutex);
+
+ for (resultPtr = forwardList; resultPtr != NULL;
+ resultPtr = resultPtr->nextPtr) {
+ ForwardingEvent *evPtr;
+ ForwardParam *paramPtr;
+
+ if (resultPtr->dst != self) {
+ /*
+ * Ignore results/events for other threads.
+ */
+
+ continue;
+ }
+
+ /*
+ * The receiver for the event exited, before processing the event. We
+ * detach the result now, wake the originator up and signal failure.
+ */
+
+ evPtr = resultPtr->evPtr;
+ paramPtr = evPtr->param;
+
+ evPtr->resultPtr = NULL;
+ resultPtr->evPtr = NULL;
+ resultPtr->result = TCL_ERROR;
+
+ ForwardSetStaticError(paramPtr, msg_send_dstlost);
+
+ Tcl_ConditionNotify(&resultPtr->done);
+ }
+
+ /*
+ * Get the map of all channels handled by the current thread. This is a
+ * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
+ * through the channels, remove all, mark them as dead.
+ */
+
+ rtmPtr = GetThreadReflectedTransformMap();
+ for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
+ ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr);
+
+ rtPtr->interp = NULL;
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ Tcl_MutexUnlock(&rtForwardMutex);
+}
+
+static void
+ForwardOpToOwnerThread(
+ ReflectedTransform *rtPtr, /* Channel instance */
+ ForwardedOperation op, /* Forwarded driver operation */
+ const void *param) /* Arguments */
+{
+ Tcl_ThreadId dst = rtPtr->thread;
+ ForwardingEvent *evPtr;
+ ForwardingResult *resultPtr;
+
+ /*
+ * We gather the lock early. This allows us to check the liveness of the
+ * channel without interference from DeleteThreadReflectedTransformMap().
+ */
+
+ Tcl_MutexLock(&rtForwardMutex);
+
+ if (rtPtr->interp == NULL) {
+ /*
+ * The channel is marked as dead. Bail out immediately, with an
+ * appropriate error. Do not forget to unlock the mutex on this path.
+ */
+
+ ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost);
+ Tcl_MutexUnlock(&rtForwardMutex);
+ return;
+ }
+
+ /*
+ * Create and initialize the event and data structures.
+ */
+
+ evPtr = ckalloc(sizeof(ForwardingEvent));
+ resultPtr = ckalloc(sizeof(ForwardingResult));
+
+ evPtr->event.proc = ForwardProc;
+ evPtr->resultPtr = resultPtr;
+ evPtr->op = op;
+ evPtr->rtPtr = rtPtr;
+ evPtr->param = (ForwardParam *) param;
+
+ resultPtr->src = Tcl_GetCurrentThread();
+ resultPtr->dst = dst;
+ resultPtr->done = NULL;
+ resultPtr->result = -1;
+ resultPtr->evPtr = evPtr;
+
+ /*
+ * Now execute the forward.
+ */
+
+ TclSpliceIn(resultPtr, forwardList);
+ /* Do not unlock here. That is done by the ConditionWait */
+
+ /*
+ * Ensure cleanup of the event if the origin thread exits while this event
+ * is pending or in progress. Exit of the destination thread is handled by
+ * DeleteThreadReflectionChannelMap(), this is set up by
+ * GetThreadReflectedTransformMap(). This is what we use the 'forwardList'
+ * (see above) for.
+ */
+
+ Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
+
+ /*
+ * Queue the event and poke the other thread's notifier.
+ */
+
+ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ Tcl_ThreadAlert(dst);
+
+ /*
+ * (*) Block until the other thread has either processed the transfer or
+ * rejected it.
+ */
+
+ while (resultPtr->result < 0) {
+ /*
+ * NOTE (1): Is it possible that the current thread goes away while
+ * waiting here? IOW Is it possible that "SrcExitProc" is called
+ * while we are here? See complementary note (2) in "SrcExitProc"
+ *
+ * The ConditionWait unlocks the mutex during the wait and relocks it
+ * immediately after.
+ */
+
+ Tcl_ConditionWait(&resultPtr->done, &rtForwardMutex, NULL);
+ }
+
+ /*
+ * Unlink result from the forwarder list. No need to lock. Either still
+ * locked, or locked by the ConditionWait
+ */
+
+ TclSpliceOut(resultPtr, forwardList);
+
+ resultPtr->nextPtr = NULL;
+ resultPtr->prevPtr = NULL;
+
+ Tcl_MutexUnlock(&rtForwardMutex);
+ Tcl_ConditionFinalize(&resultPtr->done);
+
+ /*
+ * Kill the cleanup handler now, and the result structure as well, before
+ * returning the success code.
+ *
+ * Note: The event structure has already been deleted by the destination
+ * notifier, after it serviced the event.
+ */
+
+ Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
+
+ ckfree(resultPtr);
+}
+
+static int
+ForwardProc(
+ Tcl_Event *evGPtr,
+ int mask)
+{
+ /*
+ * Notes regarding access to the referenced data.
+ *
+ * In principle the data belongs to the originating thread (see
+ * evPtr->src), however this thread is currently blocked at (*), i.e.
+ * quiescent. Because of this we can treat the data as belonging to us,
+ * without fear of race conditions. I.e. we can read and write as we like.
+ *
+ * The only thing we cannot be sure of is the resultPtr. This can be be
+ * NULLed if the originating thread went away while the event is handled
+ * here now.
+ */
+
+ ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
+ ForwardingResult *resultPtr = evPtr->resultPtr;
+ ReflectedTransform *rtPtr = evPtr->rtPtr;
+ Tcl_Interp *interp = rtPtr->interp;
+ ForwardParam *paramPtr = evPtr->param;
+ Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
+ ReflectedTransformMap *rtmPtr;
+ /* Map of reflected channels with handlers in
+ * this interp. */
+ Tcl_HashEntry *hPtr; /* Entry in the above map */
+
+ /*
+ * Ignore the event if no one is waiting for its result anymore.
+ */
+
+ if (!resultPtr) {
+ return 1;
+ }
+
+ paramPtr->base.code = TCL_OK;
+ paramPtr->base.msgStr = NULL;
+ paramPtr->base.mustFree = 0;
+
+ switch (evPtr->op) {
+ /*
+ * The destination thread for the following operations is
+ * rtPtr->thread, which contains rtPtr->interp, the interp we have to
+ * call upon for the driver.
+ */
+
+ case ForwardedClose:
+ /*
+ * No parameters/results.
+ */
+
+ if (InvokeTclMethod(rtPtr, "finalize", NULL, NULL,
+ &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+
+ /*
+ * Freeing is done here, in the origin thread, because the argv[]
+ * objects belong to this thread. Deallocating them in a different
+ * thread is not allowed
+ */
+
+ /*
+ * Remove the channel from the map before releasing the memory, to
+ * prevent future accesses (like by 'postevent') from finding and
+ * dereferencing a dangling pointer.
+ */
+
+ rtmPtr = GetReflectedTransformMap(interp);
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * In a threaded interpreter we manage a per-thread map as well, to
+ * allow us to survive if the script level pulls the rug out under a
+ * channel by deleting the owning thread.
+ */
+
+ rtmPtr = GetThreadReflectedTransformMap();
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ Tcl_DeleteHashEntry(hPtr);
+
+ Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+ break;
+
+ case ForwardedInput: {
+ Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
+ paramPtr->transform.buf, paramPtr->transform.size);
+ Tcl_IncrRefCount(bufObj);
+
+ if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->transform.size = -1;
+ } else {
+ /*
+ * Process a regular return. Contains the transformation result.
+ * Sent it back to the request originator.
+ */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev;
+ /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ paramPtr->transform.size = bytec;
+
+ if (bytec > 0) {
+ paramPtr->transform.buf = ckalloc(bytec);
+ memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
+ } else {
+ paramPtr->transform.buf = NULL;
+ }
+ }
+
+ Tcl_DecrRefCount(bufObj);
+ break;
+ }
+
+ case ForwardedOutput: {
+ Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
+ paramPtr->transform.buf, paramPtr->transform.size);
+ Tcl_IncrRefCount(bufObj);
+
+ if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->transform.size = -1;
+ } else {
+ /*
+ * Process a regular return. Contains the transformation result.
+ * Sent it back to the request originator.
+ */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev;
+ /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ paramPtr->transform.size = bytec;
+
+ if (bytec > 0) {
+ paramPtr->transform.buf = ckalloc(bytec);
+ memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
+ } else {
+ paramPtr->transform.buf = NULL;
+ }
+ }
+
+ Tcl_DecrRefCount(bufObj);
+ break;
+ }
+
+ case ForwardedDrain: {
+ if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->transform.size = -1;
+ } else {
+ /*
+ * Process a regular return. Contains the transformation result.
+ * Sent it back to the request originator.
+ */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ paramPtr->transform.size = bytec;
+
+ if (bytec > 0) {
+ paramPtr->transform.buf = ckalloc(bytec);
+ memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
+ } else {
+ paramPtr->transform.buf = NULL;
+ }
+ }
+ break;
+ }
+
+ case ForwardedFlush: {
+ if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->transform.size = -1;
+ } else {
+ /*
+ * Process a regular return. Contains the transformation result.
+ * Sent it back to the request originator.
+ */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev;
+ /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ paramPtr->transform.size = bytec;
+
+ if (bytec > 0) {
+ paramPtr->transform.buf = ckalloc(bytec);
+ memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
+ } else {
+ paramPtr->transform.buf = NULL;
+ }
+ }
+ break;
+ }
+
+ case ForwardedClear: {
+ (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
+ break;
+ }
+
+ case ForwardedLimit:
+ if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->limit.max = -1;
+ } else if (Tcl_GetIntFromObj(interp, resObj,
+ &paramPtr->limit.max) != TCL_OK) {
+ ForwardSetObjError(paramPtr, MarshallError(interp));
+ paramPtr->limit.max = -1;
+ }
+ break;
+
+ default:
+ /*
+ * Bad operation code.
+ */
+ Tcl_Panic("Bad operation code in ForwardProc");
+ break;
+ }
+
+ /*
+ * Remove the reference we held on the result of the invoke, if we had
+ * such.
+ */
+
+ if (resObj != NULL) {
+ Tcl_DecrRefCount(resObj);
+ }
+
+ if (resultPtr) {
+ /*
+ * Report the forwarding result synchronously to the waiting caller.
+ * This unblocks (*) as well. This is wrapped into a conditional
+ * because the caller may have exited in the mean time.
+ */
+
+ Tcl_MutexLock(&rtForwardMutex);
+ resultPtr->result = TCL_OK;
+ Tcl_ConditionNotify(&resultPtr->done);
+ Tcl_MutexUnlock(&rtForwardMutex);
+ }
+
+ return 1;
+}
+
+static void
+SrcExitProc(
+ ClientData clientData)
+{
+ ForwardingEvent *evPtr = clientData;
+ ForwardingResult *resultPtr;
+ ForwardParam *paramPtr;
+
+ /*
+ * NOTE (2): Can this handler be called with the originator blocked?
+ */
+
+ /*
+ * The originator for the event exited. It is not sure if this can happen,
+ * as the originator should be blocked at (*) while the event is in
+ * transit/pending.
+ *
+ * We make sure that the event cannot refer to the result anymore, remove
+ * it from the list of pending results and free the structure. Locking the
+ * access ensures that we cannot get in conflict with "ForwardProc",
+ * should it already execute the event.
+ */
+
+ Tcl_MutexLock(&rtForwardMutex);
+
+ resultPtr = evPtr->resultPtr;
+ paramPtr = evPtr->param;
+
+ evPtr->resultPtr = NULL;
+ resultPtr->evPtr = NULL;
+ resultPtr->result = TCL_ERROR;
+
+ ForwardSetStaticError(paramPtr, msg_send_originlost);
+
+ /*
+ * See below: TclSpliceOut(resultPtr, forwardList);
+ */
+
+ Tcl_MutexUnlock(&rtForwardMutex);
+
+ /*
+ * This unlocks (*). The structure will be spliced out and freed by
+ * "ForwardProc". Maybe.
+ */
+
+ Tcl_ConditionNotify(&resultPtr->done);
+}
+
+static void
+ForwardSetObjError(
+ ForwardParam *paramPtr,
+ Tcl_Obj *obj)
+{
+ int len;
+ const char *msgStr = Tcl_GetStringFromObj(obj, &len);
+
+ len++;
+ ForwardSetDynamicError(paramPtr, ckalloc(len));
+ memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerKill --
+ *
+ * Timer management. Removes the internal timer if it exists.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimerKill(
+ ReflectedTransform *rtPtr)
+{
+ if (rtPtr->timer == NULL) {
+ return;
+ }
+
+ /*
+ * Delete an existing flush-out timer, prevent it from firing on a
+ * removed/dead channel.
+ */
+
+ Tcl_DeleteTimerHandler(rtPtr->timer);
+ rtPtr->timer = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerSetup --
+ *
+ * Timer management. Creates the internal timer if it does not exist.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimerSetup(
+ ReflectedTransform *rtPtr)
+{
+ if (rtPtr->timer != NULL) {
+ return;
+ }
+
+ rtPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TimerRun, rtPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerRun --
+ *
+ * Called by the notifier (-> timer) to flush out information waiting in
+ * channel buffers.
+ *
+ * Side effects:
+ * As of 'Tcl_NotifyChannel'.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimerRun(
+ ClientData clientData)
+{
+ ReflectedTransform *rtPtr = clientData;
+
+ rtPtr->timer = NULL;
+ Tcl_NotifyChannel(rtPtr->chan, TCL_READABLE);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultInit --
+ *
+ * Initializes the specified buffer structure. The structure will contain
+ * valid information for an emtpy buffer.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResultInit(
+ ResultBuffer *rPtr) /* Reference to the structure to
+ * initialize. */
+{
+ rPtr->used = 0;
+ rPtr->allocated = 0;
+ rPtr->buf = NULL;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultClear --
+ *
+ * Deallocates any memory allocated by 'ResultAdd'.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResultClear(
+ ResultBuffer *rPtr) /* Reference to the buffer to clear out */
+{
+ rPtr->used = 0;
+
+ if (!rPtr->allocated) {
+ return;
+ }
+
+ Tcl_Free((char *) rPtr->buf);
+ rPtr->buf = NULL;
+ rPtr->allocated = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultAdd --
+ *
+ * Adds the bytes in the specified array to the buffer, by appending it.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResultAdd(
+ ResultBuffer *rPtr, /* The buffer to extend */
+ unsigned char *buf, /* The buffer to read from */
+ int toWrite) /* The number of bytes in 'buf' */
+{
+ if ((rPtr->used + toWrite + 1) > rPtr->allocated) {
+ /*
+ * Extension of the internal buffer is required.
+ * NOTE: Currently linear. Should be doubling to amortize.
+ */
+
+ if (rPtr->allocated == 0) {
+ rPtr->allocated = toWrite + RB_INCREMENT;
+ rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated));
+ } else {
+ rPtr->allocated += toWrite + RB_INCREMENT;
+ rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf,
+ rPtr->allocated));
+ }
+ }
+
+ /*
+ * Now copy data.
+ */
+
+ memcpy(rPtr->buf + rPtr->used, buf, toWrite);
+ rPtr->used += toWrite;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultCopy --
+ *
+ * Copies the requested number of bytes from the buffer into the
+ * specified array and removes them from the buffer afterward. Copies
+ * less if there is not enough data in the buffer.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * The number of actually copied bytes, possibly less than 'toRead'.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ResultCopy(
+ ResultBuffer *rPtr, /* The buffer to read from */
+ unsigned char *buf, /* The buffer to copy into */
+ int toRead) /* Number of requested bytes */
+{
+ int copied;
+
+ if (rPtr->used == 0) {
+ /*
+ * Nothing to copy in the case of an empty buffer.
+ */
+
+ copied = 0;
+ } else if (rPtr->used == toRead) {
+ /*
+ * We have just enough. Copy everything to the caller.
+ */
+
+ memcpy(buf, rPtr->buf, toRead);
+ rPtr->used = 0;
+ copied = toRead;
+ } else if (rPtr->used > toRead) {
+ /*
+ * The internal buffer contains more than requested. Copy the
+ * requested subset to the caller, and shift the remaining bytes down.
+ */
+
+ memcpy(buf, rPtr->buf, toRead);
+ memmove(rPtr->buf, rPtr->buf + toRead, rPtr->used - toRead);
+
+ rPtr->used -= toRead;
+ copied = toRead;
+ } else {
+ /*
+ * There is not enough in the buffer to satisfy the caller, so take
+ * everything.
+ */
+
+ memcpy(buf, rPtr->buf, rPtr->used);
+ toRead = rPtr->used;
+ rPtr->used = 0;
+ copied = toRead;
+ }
+
+ /* -- common postwork code ------- */
+
+ return copied;
+}
+
+static int
+TransformRead(
+ ReflectedTransform *rtPtr,
+ int *errorCodePtr,
+ unsigned char *buf,
+ int toRead)
+{
+ Tcl_Obj *bufObj;
+ Tcl_Obj *resObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.transform.buf = (char *) buf;
+ p.transform.size = toRead;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rtPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+ ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
+ ckfree(p.transform.buf);
+ return 1;
+ }
+#endif
+
+ /* ASSERT: rtPtr->method & FLAG(METH_READ) */
+ /* ASSERT: rtPtr->mode & TCL_READABLE */
+
+ bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead);
+ Tcl_IncrRefCount(bufObj);
+
+ if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
+ Tcl_SetChannelError(rtPtr->chan, resObj);
+ Tcl_DecrRefCount(bufObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+ ResultAdd(&rtPtr->result, bytev, bytec);
+
+ Tcl_DecrRefCount(bufObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ return 1;
+}
+
+static int
+TransformWrite(
+ ReflectedTransform *rtPtr,
+ int *errorCodePtr,
+ unsigned char *buf,
+ int toWrite)
+{
+ Tcl_Obj *bufObj;
+ Tcl_Obj *resObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+ int res;
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.transform.buf = (char *) buf;
+ p.transform.size = toWrite;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedOutput, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rtPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+ res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
+ p.transform.size);
+ ckfree(p.transform.buf);
+ } else
+#endif
+ {
+ /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
+ /* ASSERT: rtPtr->mode & TCL_WRITABLE */
+
+ bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
+ Tcl_IncrRefCount(bufObj);
+ if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ *errorCodePtr = EINVAL;
+ Tcl_SetChannelError(rtPtr->chan, resObj);
+
+ Tcl_DecrRefCount(bufObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+ res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec);
+
+ Tcl_DecrRefCount(bufObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ }
+
+ if (res < 0) {
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ return 1;
+}
+
+static int
+TransformDrain(
+ ReflectedTransform *rtPtr,
+ int *errorCodePtr)
+{
+ Tcl_Obj *resObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedDrain, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rtPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+ ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
+ ckfree(p.transform.buf);
+ } else
+#endif
+ {
+ if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
+ Tcl_SetChannelError(rtPtr->chan, resObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+ ResultAdd(&rtPtr->result, bytev, bytec);
+
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ }
+
+ rtPtr->readIsDrained = 1;
+ return 1;
+}
+
+static int
+TransformFlush(
+ ReflectedTransform *rtPtr,
+ int *errorCodePtr,
+ int op)
+{
+ Tcl_Obj *resObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+ int res;
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedFlush, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rtPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+ if (op == FLUSH_WRITE) {
+ res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
+ p.transform.size);
+ } else {
+ res = 0;
+ }
+ ckfree(p.transform.buf);
+ } else
+#endif
+ {
+ if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
+ Tcl_SetChannelError(rtPtr->chan, resObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ if (op == FLUSH_WRITE) {
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+ res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec);
+ } else {
+ res = 0;
+ }
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ }
+
+ if (res < 0) {
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ return 1;
+}
+
+static void
+TransformClear(
+ ReflectedTransform *rtPtr)
+{
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
+ return;
+ }
+#endif
+
+ /* ASSERT: rtPtr->method & FLAG(METH_READ) */
+ /* ASSERT: rtPtr->mode & TCL_READABLE */
+
+ (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
+
+ rtPtr->readIsDrained = 0;
+ ResultClear(&rtPtr->result);
+}
+
+static int
+TransformLimit(
+ ReflectedTransform *rtPtr,
+ int *errorCodePtr,
+ int *maxPtr)
+{
+ Tcl_Obj *resObj;
+ Tcl_InterpState sr; /* State of handler interp */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rtPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rtPtr, ForwardedLimit, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rtPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ *errorCodePtr = EOK;
+ *maxPtr = p.limit.max;
+ return 1;
+ }
+#endif
+
+ /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
+ /* ASSERT: rtPtr->mode & TCL_WRITABLE */
+
+ if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
+ Tcl_SetChannelError(rtPtr->chan, resObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ *errorCodePtr = EINVAL;
+ return 0;
+ }
+
+ sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
+
+ if (Tcl_GetIntFromObj(rtPtr->interp, resObj, maxPtr) != TCL_OK) {
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_SetChannelError(rtPtr->chan, MarshallError(rtPtr->interp));
+ *errorCodePtr = EINVAL;
+
+ Tcl_RestoreInterpState(rtPtr->interp, sr);
+ return 0;
+ }
+
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_RestoreInterpState(rtPtr->interp, sr);
+ return 1;
+}
+
+/* DUPLICATE of HaveVersion() in tclIO.c
+ *----------------------------------------------------------------------
+ *
+ * HaveVersion --
+ *
+ * Return whether a channel type is (at least) of a given version.
+ *
+ * Results:
+ * True if the minimum version is exceeded by the version actually
+ * present.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+HaveVersion(
+ const Tcl_ChannelType *chanTypePtr,
+ Tcl_ChannelTypeVersion minimumVersion)
+{
+ Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr);
+
+ return PTR2INT(actualVersion) >= PTR2INT(minimumVersion);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index ec4a9d9..ab2b094 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -10,6 +10,12 @@
*/
#include "tclInt.h"
+
+#if defined(_WIN32) && defined(UNICODE)
+/* On Windows, we always need the ASCII version. */
+# undef gai_strerror
+# define gai_strerror gai_strerrorA
+#endif
/*
*---------------------------------------------------------------------------
@@ -81,30 +87,185 @@ TclSockGetPort(
*----------------------------------------------------------------------
*/
+#ifdef _WIN32
+# define PTR2SOCK(a) (SOCKET)a
+#else
+# define PTR2SOCK(a) PTR2INT(a)
+#endif
int
TclSockMinimumBuffers(
- int sock, /* Socket file descriptor */
+ ClientData sock, /* Socket file descriptor */
int size) /* Minimum buffer size */
{
int current;
socklen_t len;
len = sizeof(int);
- getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
+ getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
+ setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
}
len = sizeof(int);
- getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
+ getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
+ setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
}
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateSocketAddress --
+ *
+ * This function initializes a sockaddr structure for a host and port.
+ *
+ * Results:
+ * 1 if the host was valid, 0 if the host could not be converted to an IP
+ * address.
+ *
+ * Side effects:
+ * Fills in the *sockaddrPtr structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCreateSocketAddress(
+ Tcl_Interp *interp, /* Interpreter for querying
+ * the desired socket family */
+ struct addrinfo **addrlist, /* Socket address list */
+ const char *host, /* Host. NULL implies INADDR_ANY */
+ int port, /* Port number */
+ int willBind, /* Is this an address to bind() to or
+ * to connect() to? */
+ const char **errorMsgPtr) /* Place to store the error message
+ * detail, if available. */
+{
+ struct addrinfo hints;
+ struct addrinfo *p;
+ struct addrinfo *v4head = NULL, *v4ptr = NULL;
+ struct addrinfo *v6head = NULL, *v6ptr = NULL;
+ char *native = NULL, portstring[TCL_INTEGER_SPACE];
+ const char *family = NULL;
+ Tcl_DString ds;
+ int result, i;
+
+ TclFormatInt(portstring, port);
+
+ if (host != NULL) {
+ native = Tcl_UtfToExternalDString(NULL, host, -1, &ds);
+ }
+
+ (void) memset(&hints, 0, sizeof(hints));
+
+ hints.ai_family = AF_UNSPEC;
+ /*
+ * Magic variable to enforce a certain address family - to be superseded
+ * by a TIP that adds explicit switches to [socket]
+ */
+ if (interp != NULL) {
+ family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0);
+ if (family != NULL) {
+ if (strcmp(family, "inet") == 0) {
+ hints.ai_family = AF_INET;
+ } else if (strcmp(family, "inet6") == 0) {
+ hints.ai_family = AF_INET6;
+ }
+ }
+ }
+
+ hints.ai_socktype = SOCK_STREAM;
+#if defined(AI_ADDRCONFIG) && !defined(_AIX)
+ /* Missing on: OpenBSD, NetBSD. Causes failure when used on AIX 5.1 */
+ hints.ai_flags |= AI_ADDRCONFIG;
+#endif
+ if (willBind) {
+ hints.ai_flags |= AI_PASSIVE;
+ }
+
+ result = getaddrinfo(native, portstring, &hints, addrlist);
+
+ if (host != NULL) {
+ Tcl_DStringFree(&ds);
+ }
+
+ if (result != 0) {
+ goto error;
+ }
+
+ /*
+ * Put IPv4 addresses before IPv6 addresses to maximize backwards
+ * compatibility of [fconfigure -sockname] output.
+ *
+ * There might be more elegant/efficient ways to do this.
+ */
+ if (willBind) {
+ for (p = *addrlist; p != NULL; p = p->ai_next) {
+ if (p->ai_family == AF_INET) {
+ if (v4head == NULL) {
+ v4head = p;
+ } else {
+ v4ptr->ai_next = p;
+ }
+ v4ptr = p;
+ } else {
+ if (v6head == NULL) {
+ v6head = p;
+ } else {
+ v6ptr->ai_next = p;
+ }
+ v6ptr = p;
+ }
+ }
+ *addrlist = NULL;
+ if (v6head != NULL) {
+ *addrlist = v6head;
+ v6ptr->ai_next = NULL;
+ }
+ if (v4head != NULL) {
+ v4ptr->ai_next = *addrlist;
+ *addrlist = v4head;
+ }
+ }
+ i = 0;
+ for (p = *addrlist; p != NULL; p = p->ai_next) {
+ i++;
+ }
+
+ return 1;
+
+ /*
+ * Ought to use gai_strerror() here...
+ */
+
+error:
+ switch (result) {
+ case EAI_NONAME:
+ case EAI_SERVICE:
+#if defined(EAI_ADDRFAMILY) && EAI_ADDRFAMILY != EAI_NONAME
+ case EAI_ADDRFAMILY:
+#endif
+#if defined(EAI_NODATA) && EAI_NODATA != EAI_NONAME
+ case EAI_NODATA:
+#endif
+ *errorMsgPtr = gai_strerror(result);
+ errno = EHOSTUNREACH;
+ return 0;
+#ifdef EAI_SYSTEM
+ case EAI_SYSTEM:
+ return 0;
+#endif
+ default:
+ *errorMsgPtr = gai_strerror(result);
+ errno = ENXIO;
+ return 0;
+ }
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index fb8b74f..17e50fa 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -28,6 +28,8 @@
* Prototypes for functions defined later in this file.
*/
+static int EvalFileCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
static FilesystemRecord*FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
@@ -35,10 +37,12 @@ static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr, const char *pattern,
Tcl_GlobTypeData *types);
static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
-
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
+static void * DivertFindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, const char *symbol);
+static void DivertUnloadFile(Tcl_LoadHandle loadHandle);
/*
* These form part of the native filesystem support. They are needed here
@@ -47,15 +51,171 @@ static void FsRecacheFilesystemList(void);
* they are not (and should not be) used anywhere else.
*/
-MODULE_SCOPE const char * tclpFileAttrStrings[];
+MODULE_SCOPE const char *const tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+
+/*
+ * Declare the native filesystem support. These functions should be considered
+ * private to Tcl, and should really not be called directly by any code other
+ * than this file (i.e. neither by Tcl's core nor by extensions). Similarly,
+ * the old string-based Tclp... native filesystem functions should not be
+ * called.
+ *
+ * The correct API to use now is the Tcl_FS... set of functions, which ensure
+ * correct and complete virtual filesystem support.
+ *
+ * We cannot make all of these static, since some of them are implemented in
+ * the platform-specific directories.
+ */
+
+static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
+static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
+static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
+static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
+static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
+
+/*
+ * The only reason these functions are not static is that they are either
+ * called by code in the native (win/unix) directories or they are actually
+ * implemented in those directories. They should simply not be called by code
+ * outside Tcl's native filesystem core i.e. they should be considered
+ * 'static' to Tcl's filesystem code (if we ever built the native filesystem
+ * support into a separate code library, this could actually be enforced).
+ */
+
+Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
+Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
+Tcl_FSStatProc TclpObjStat;
+Tcl_FSAccessProc TclpObjAccess;
+Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
+Tcl_FSChdirProc TclpObjChdir;
+Tcl_FSLstatProc TclpObjLstat;
+Tcl_FSCopyFileProc TclpObjCopyFile;
+Tcl_FSDeleteFileProc TclpObjDeleteFile;
+Tcl_FSRenameFileProc TclpObjRenameFile;
+Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
+Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
+Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
+Tcl_FSUnloadFileProc TclpUnloadFile;
+Tcl_FSLinkProc TclpObjLink;
+Tcl_FSListVolumesProc TclpObjListVolumes;
+
+/*
+ * Define the native filesystem dispatch table. If necessary, it is ok to make
+ * this non-static, but it should only be accessed by the functions actually
+ * listed within it (or perhaps other helper functions of them). Anything
+ * which is not part of this 'native filesystem implementation' should not be
+ * delving inside here!
+ */
+
+const Tcl_Filesystem tclNativeFilesystem = {
+ "native",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_2,
+ TclNativePathInFilesystem,
+ TclNativeDupInternalRep,
+ NativeFreeInternalRep,
+ TclpNativeToNormalized,
+ TclNativeCreateNativeRep,
+ TclpObjNormalizePath,
+ TclpFilesystemPathType,
+ NativeFilesystemSeparator,
+ TclpObjStat,
+ TclpObjAccess,
+ TclpOpenFileChannel,
+ TclpMatchInDirectory,
+ TclpUtime,
+#ifndef S_IFLNK
+ NULL,
+#else
+ TclpObjLink,
+#endif /* S_IFLNK */
+ TclpObjListVolumes,
+ NativeFileAttrStrings,
+ NativeFileAttrsGet,
+ NativeFileAttrsSet,
+ TclpObjCreateDirectory,
+ TclpObjRemoveDirectory,
+ TclpObjDeleteFile,
+ TclpObjCopyFile,
+ TclpObjRenameFile,
+ TclpObjCopyDirectory,
+ TclpObjLstat,
+ TclpDlopen,
+ /* Needs a cast since we're using version_2. */
+ (Tcl_FSGetCwdProc *) TclpGetNativeCwd,
+ TclpObjChdir
+};
+
+/*
+ * Define the tail of the linked list. Note that for unconventional uses of
+ * Tcl without a native filesystem, we may in the future wish to modify the
+ * current approach of hard-coding the native filesystem in the lookup list
+ * 'filesystemList' below.
+ *
+ * We initialize the record so that it thinks one file uses it. This means it
+ * will never be freed.
+ */
+
+static FilesystemRecord nativeFilesystemRecord = {
+ NULL,
+ &tclNativeFilesystem,
+ 1,
+ NULL,
+ NULL
+};
/*
+ * This is incremented each time we modify the linked list of filesystems. Any
+ * time it changes, all cached filesystem representations are suspect and must
+ * be freed. For multithreading builds, change of the filesystem epoch will
+ * trigger cache cleanup in all threads.
+ */
+
+static int theFilesystemEpoch = 0;
+
+/*
+ * Stores the linked list of filesystems. A 1:1 copy of this list is also
+ * maintained in the TSD for each thread. This is to avoid synchronization
+ * issues.
+ */
+
+static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
+TCL_DECLARE_MUTEX(filesystemMutex)
+
+/*
+ * Used to implement Tcl_FSGetCwd in a file-system independent way.
+ */
+
+static Tcl_Obj *cwdPathPtr = NULL;
+static int cwdPathEpoch = 0;
+static ClientData cwdClientData = NULL;
+TCL_DECLARE_MUTEX(cwdMutex)
+
+Tcl_ThreadDataKey tclFsDataKey;
+
+/*
+ * One of these structures is used each time we successfully load a file from
+ * a file system by way of making a temporary copy of the file on the native
+ * filesystem. We need to store both the actual unloadProc/clientData
+ * combination which was used, and the original and modified filenames, so
+ * that we can correctly undo the entire operation when we want to unload the
+ * code.
+ */
+
+typedef struct FsDivertLoad {
+ Tcl_LoadHandle loadHandle;
+ Tcl_FSUnloadFileProc *unloadProcPtr;
+ Tcl_Obj *divertedFile;
+ const Tcl_Filesystem *divertedFilesystem;
+ ClientData divertedFileNativeRep;
+} FsDivertLoad;
+
+/*
* The following functions are obsolete string based APIs, and should be
* removed in a future release (Tcl 9 would be a good time).
*/
-
/* Obsolete */
int
Tcl_Stat(
@@ -64,7 +224,7 @@ Tcl_Stat(
{
int ret;
Tcl_StatBuf buf;
- Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSStat(pathPtr, &buf);
@@ -72,6 +232,7 @@ Tcl_Stat(
if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt tmp1, tmp2, tmp3 = 0;
+
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
@@ -88,10 +249,10 @@ Tcl_Stat(
* Tcl_WideInt.
*/
- tmp1 = (Tcl_WideInt) buf.st_ino;
- tmp2 = (Tcl_WideInt) buf.st_size;
+ tmp1 = (Tcl_WideInt) buf.st_ino;
+ tmp2 = (Tcl_WideInt) buf.st_size;
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- tmp3 = (Tcl_WideInt) buf.st_blocks;
+ tmp3 = (Tcl_WideInt) buf.st_blocks;
#endif
if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) {
@@ -198,16 +359,15 @@ Tcl_GetCwd(
Tcl_Interp *interp,
Tcl_DString *cwdPtr)
{
- Tcl_Obj *cwd;
- cwd = Tcl_FSGetCwd(interp);
+ Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
+
if (cwd == NULL) {
return NULL;
- } else {
- Tcl_DStringInit(cwdPtr);
- Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
- Tcl_DecrRefCount(cwd);
- return Tcl_DStringValue(cwdPtr);
}
+ Tcl_DStringInit(cwdPtr);
+ Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
+ Tcl_DecrRefCount(cwd);
+ return Tcl_DStringValue(cwdPtr);
}
/* Obsolete */
@@ -219,6 +379,7 @@ Tcl_EvalFile(
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSEvalFile(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
@@ -226,234 +387,14 @@ Tcl_EvalFile(
}
/*
- * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
- * complete, general hooked filesystem APIs should be used instead. This
- * define decides whether to include the obsolete hooks and related code. If
- * these are removed, we'll also want to remove them from stubs/tclInt. The
- * only known users of these APIs are prowrap and mktclapp. New
- * code/extensions should not use them, since they do not provide as full
- * support as the full filesystem API.
- *
- * As soon as prowrap and mktclapp are updated to use the full filesystem
- * support, I suggest all these hooks are removed.
- */
-
-#undef USE_OBSOLETE_FS_HOOKS
-
-#ifdef USE_OBSOLETE_FS_HOOKS
-
-/*
- * The following typedef declarations allow for hooking into the chain of
- * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
- * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked
- * list is defined.
- */
-
-typedef struct StatProc {
- TclStatProc_ *proc; /* Function to process a 'stat()' call */
- struct StatProc *nextPtr; /* The next 'stat()' function to call */
-} StatProc;
-
-typedef struct AccessProc {
- TclAccessProc_ *proc; /* Function to process a 'access()' call */
- struct AccessProc *nextPtr; /* The next 'access()' function to call */
-} AccessProc;
-
-typedef struct OpenFileChannelProc {
- TclOpenFileChannelProc_ *proc;
- /* Function to process a
- * 'Tcl_OpenFileChannel()' call */
- struct OpenFileChannelProc *nextPtr;
- /* The next 'Tcl_OpenFileChannel()' function
- * to call */
-} OpenFileChannelProc;
-
-/*
- * For each type of (obsolete) hookable function, a static node is declared to
- * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)')
- * and the respective list is initialized as a pointer to that node.
- *
- * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these
- * statically declared list entry cannot be inadvertently removed.
- *
- * This method avoids the need to call any sort of "initialization" function.
- *
- * All three lists are protected by a global obsoleteFsHookMutex.
- */
-
-static StatProc *statProcList = NULL;
-static AccessProc *accessProcList = NULL;
-static OpenFileChannelProc *openFileChannelProcList = NULL;
-
-TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
-
-#endif /* USE_OBSOLETE_FS_HOOKS */
-
-/*
- * Declare the native filesystem support. These functions should be considered
- * private to Tcl, and should really not be called directly by any code other
- * than this file (i.e. neither by Tcl's core nor by extensions). Similarly,
- * the old string-based Tclp... native filesystem functions should not be
- * called.
- *
- * The correct API to use now is the Tcl_FS... set of functions, which ensure
- * correct and complete virtual filesystem support.
- *
- * We cannot make all of these static, since some of them are implemented in
- * the platform-specific directories.
- */
-
-static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
-static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
-static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
-static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
-static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
-
-/*
- * The only reason these functions are not static is that they are either
- * called by code in the native (win/unix) directories or they are actually
- * implemented in those directories. They should simply not be called by code
- * outside Tcl's native filesystem core i.e. they should be considered
- * 'static' to Tcl's filesystem code (if we ever built the native filesystem
- * support into a separate code library, this could actually be enforced).
- */
-
-Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
-Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
-Tcl_FSStatProc TclpObjStat;
-Tcl_FSAccessProc TclpObjAccess;
-Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
-Tcl_FSChdirProc TclpObjChdir;
-Tcl_FSLstatProc TclpObjLstat;
-Tcl_FSCopyFileProc TclpObjCopyFile;
-Tcl_FSDeleteFileProc TclpObjDeleteFile;
-Tcl_FSRenameFileProc TclpObjRenameFile;
-Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
-Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
-Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
-Tcl_FSUnloadFileProc TclpUnloadFile;
-Tcl_FSLinkProc TclpObjLink;
-Tcl_FSListVolumesProc TclpObjListVolumes;
-
-/*
- * Define the native filesystem dispatch table. If necessary, it is ok to make
- * this non-static, but it should only be accessed by the functions actually
- * listed within it (or perhaps other helper functions of them). Anything
- * which is not part of this 'native filesystem implementation' should not be
- * delving inside here!
- */
-
-Tcl_Filesystem tclNativeFilesystem = {
- "native",
- sizeof(Tcl_Filesystem),
- TCL_FILESYSTEM_VERSION_2,
- &TclNativePathInFilesystem,
- &TclNativeDupInternalRep,
- &NativeFreeInternalRep,
- &TclpNativeToNormalized,
- &TclNativeCreateNativeRep,
- &TclpObjNormalizePath,
- &TclpFilesystemPathType,
- &NativeFilesystemSeparator,
- &TclpObjStat,
- &TclpObjAccess,
- &TclpOpenFileChannel,
- &TclpMatchInDirectory,
- &TclpUtime,
-#ifndef S_IFLNK
- NULL,
-#else
- &TclpObjLink,
-#endif /* S_IFLNK */
- &TclpObjListVolumes,
- &NativeFileAttrStrings,
- &NativeFileAttrsGet,
- &NativeFileAttrsSet,
- &TclpObjCreateDirectory,
- &TclpObjRemoveDirectory,
- &TclpObjDeleteFile,
- &TclpObjCopyFile,
- &TclpObjRenameFile,
- &TclpObjCopyDirectory,
- &TclpObjLstat,
- &TclpDlopen,
- /* Needs a cast since we're using version_2 */
- (Tcl_FSGetCwdProc *) &TclpGetNativeCwd,
- &TclpObjChdir
-};
-
-/*
- * Define the tail of the linked list. Note that for unconventional uses of
- * Tcl without a native filesystem, we may in the future wish to modify the
- * current approach of hard-coding the native filesystem in the lookup list
- * 'filesystemList' below.
- *
- * We initialize the record so that it thinks one file uses it. This means it
- * will never be freed.
- */
-
-static FilesystemRecord nativeFilesystemRecord = {
- NULL,
- &tclNativeFilesystem,
- 1,
- NULL
-};
-
-/*
- * This is incremented each time we modify the linked list of filesystems. Any
- * time it changes, all cached filesystem representations are suspect and must
- * be freed. For multithreading builds, change of the filesystem epoch will
- * trigger cache cleanup in all threads.
- */
-
-static int theFilesystemEpoch = 0;
-
-/*
- * Stores the linked list of filesystems. A 1:1 copy of this list is also
- * maintained in the TSD for each thread. This is to avoid synchronization
- * issues.
- */
-
-static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
-TCL_DECLARE_MUTEX(filesystemMutex)
-
-/*
- * Used to implement Tcl_FSGetCwd in a file-system independent way.
- */
-
-static Tcl_Obj* cwdPathPtr = NULL;
-static int cwdPathEpoch = 0;
-static ClientData cwdClientData = NULL;
-TCL_DECLARE_MUTEX(cwdMutex)
-
-Tcl_ThreadDataKey tclFsDataKey;
-
-/*
- * One of these structures is used each time we successfully load a file from
- * a file system by way of making a temporary copy of the file on the native
- * filesystem. We need to store both the actual unloadProc/clientData
- * combination which was used, and the original and modified filenames, so
- * that we can correctly undo the entire operation when we want to unload the
- * code.
- */
-
-typedef struct FsDivertLoad {
- Tcl_LoadHandle loadHandle;
- Tcl_FSUnloadFileProc *unloadProcPtr;
- Tcl_Obj *divertedFile;
- const Tcl_Filesystem *divertedFilesystem;
- ClientData divertedFileNativeRep;
-} FsDivertLoad;
-
-/*
- * Now move on to the basic filesystem implementation
+ * Now move on to the basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd;
+ ThreadSpecificData *tsdPtr = cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/*
@@ -476,7 +417,7 @@ FsThrExitProc(
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
- ckfree((char *)fsRecPtr);
+ ckfree(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
@@ -518,7 +459,7 @@ TclFSCwdIsNative(void)
int
TclFSCwdPointerEquals(
- Tcl_Obj** pathPtrPtr)
+ Tcl_Obj **pathPtrPtr)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
@@ -547,7 +488,7 @@ TclFSCwdPointerEquals(
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->initialized == 0) {
- Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
+ Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
tsdPtr->initialized = 1;
}
@@ -563,7 +504,7 @@ TclFSCwdPointerEquals(
str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
- if (len1 == len2 && !strcmp(str1,str2)) {
+ if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* They are equal, but different objects. Update so they will be
* the same object in the future.
@@ -594,7 +535,7 @@ FsRecacheFilesystemList(void)
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
- ckfree((char *)fsRecPtr);
+ ckfree(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
@@ -619,7 +560,7 @@ FsRecacheFilesystemList(void)
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
- tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
+ tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
tmpFsRecPtr->prevPtr = NULL;
@@ -635,7 +576,7 @@ FsRecacheFilesystemList(void)
*/
if (tsdPtr->initialized == 0) {
- Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
+ Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
tsdPtr->initialized = 1;
}
}
@@ -646,6 +587,7 @@ FsGetFirstFilesystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
FilesystemRecord *fsRecPtr;
+
#ifndef TCL_THREADS
tsdPtr->filesystemEpoch = theFilesystemEpoch;
fsRecPtr = filesystemList;
@@ -672,6 +614,7 @@ TclFSEpochOk(
int filesystemEpoch)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+
(void) FsGetFirstFilesystem();
return (filesystemEpoch == tsdPtr->filesystemEpoch);
}
@@ -686,7 +629,7 @@ FsUpdateCwd(
ClientData clientData)
{
int len;
- char *str = NULL;
+ const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (cwdObj != NULL) {
@@ -710,7 +653,7 @@ FsUpdateCwd(
*/
cwdPathPtr = Tcl_NewStringObj(str, len);
- Tcl_IncrRefCount(cwdPathPtr);
+ Tcl_IncrRefCount(cwdPathPtr);
cwdClientData = TclNativeDupInternalRep(clientData);
}
@@ -777,19 +720,20 @@ TclFinalizeFilesystem(void)
/*
* Remove all filesystems, freeing any allocated memory that is no longer
- * needed
+ * needed.
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
+
if (fsRecPtr->fileRefCount <= 0) {
/*
* The native filesystem is static, so we don't free it.
*/
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- ckfree((char *)fsRecPtr);
+ ckfree(fsRecPtr);
}
}
fsRecPtr = tmpFsRecPtr;
@@ -801,11 +745,6 @@ TclFinalizeFilesystem(void)
* filesystem is likely to fail.
*/
-#ifdef USE_OBSOLETE_FS_HOOKS
- statProcList = NULL;
- accessProcList = NULL;
- openFileChannelProcList = NULL;
-#endif
#ifdef __WIN32__
TclWinEncodingsCleanup();
#endif
@@ -879,8 +818,8 @@ TclResetFilesystem(void)
int
Tcl_FSRegister(
- ClientData clientData, /* Client specific data for this fs */
- Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */
+ ClientData clientData, /* Client specific data for this fs. */
+ const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
@@ -888,7 +827,7 @@ Tcl_FSRegister(
return TCL_ERROR;
}
- newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
+ newFilesystemPtr = ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
@@ -959,7 +898,7 @@ Tcl_FSRegister(
int
Tcl_FSUnregister(
- Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
+ const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -996,7 +935,7 @@ Tcl_FSUnregister(
fsRecPtr->fileRefCount--;
if (fsRecPtr->fileRefCount <= 0) {
- ckfree((char *)fsRecPtr);
+ ckfree(fsRecPtr);
}
retVal = TCL_OK;
@@ -1053,7 +992,7 @@ Tcl_FSUnregister(
int
Tcl_FSMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive error messages, but
- * may be NULL. */
+ * may be NULL. */
Tcl_Obj *resultPtr, /* List object to receive results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
const char *pattern, /* Pattern to match against. */
@@ -1065,7 +1004,7 @@ Tcl_FSMatchInDirectory(
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
int resLength, i, ret = -1;
- if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
+ if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
/*
* We don't currently allow querying of mounts by external code (a
* valuable future step), so since we're the only function that
@@ -1092,8 +1031,8 @@ Tcl_FSMatchInDirectory(
Tcl_SetErrno(ENOENT);
return -1;
}
- ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
- pattern, types);
+ ret = fsPtr->matchInDirectoryProc(interp, resultPtr, pathPtr, pattern,
+ types);
if (ret == TCL_OK && pattern != NULL) {
FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
}
@@ -1102,7 +1041,7 @@ Tcl_FSMatchInDirectory(
/*
* If the path isn't empty, we have no idea how to match files in a
- * directory which belongs to no known filesystem
+ * directory which belongs to no known filesystem.
*/
if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
@@ -1133,8 +1072,8 @@ Tcl_FSMatchInDirectory(
if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
TclNewObj(tmpResultPtr);
Tcl_IncrRefCount(tmpResultPtr);
- ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
- pattern, types);
+ ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern,
+ types);
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
@@ -1178,7 +1117,7 @@ static void
FsAddMountsToGlobResult(
Tcl_Obj *resultPtr, /* The current list of matching paths; must
* not be shared! */
- Tcl_Obj *pathPtr, /* The directory in question */
+ Tcl_Obj *pathPtr, /* The directory in question. */
const char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
@@ -1219,7 +1158,7 @@ FsAddMountsToGlobResult(
Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
gLength--;
}
- break; /* Break out of for loop */
+ break; /* Break out of for loop. */
}
}
if (!found && dir) {
@@ -1309,7 +1248,7 @@ FsAddMountsToGlobResult(
void
Tcl_FSMountsChanged(
- Tcl_Filesystem *fsPtr)
+ const Tcl_Filesystem *fsPtr)
{
/*
* We currently don't do anything with this parameter. We could in the
@@ -1350,7 +1289,7 @@ Tcl_FSMountsChanged(
ClientData
Tcl_FSData(
- Tcl_Filesystem *fsPtr) /* The filesystem record to query. */
+ const Tcl_Filesystem *fsPtr) /* The filesystem record to query. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
@@ -1404,8 +1343,8 @@ Tcl_FSData(
int
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
- Tcl_Obj *pathPtr, /* The path to normalize in place */
- int startAt, /* Start at this char-offset */
+ Tcl_Obj *pathPtr, /* The path to normalize in place. */
+ int startAt, /* Start at this char-offset. */
ClientData *clientDataPtr) /* If we generated a complete normalized path
* for a given filesystem, we can optionally
* return an fs-specific clientdata here. */
@@ -1423,37 +1362,42 @@ TclFSNormalizeToUniquePath(
firstFsRecPtr = FsGetFirstFilesystem();
- fsRecPtr = firstFsRecPtr;
- while (fsRecPtr != NULL) {
- if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
- Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
- if (proc != NULL) {
- startAt = (*proc)(interp, pathPtr, startAt);
- }
- break;
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
+ continue;
}
- fsRecPtr = fsRecPtr->nextPtr;
+
+ /*
+ * TODO: Assume that we always find the native file system; it should
+ * always be there...
+ */
+
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
+ }
+ break;
}
- fsRecPtr = firstFsRecPtr;
- while (fsRecPtr != NULL) {
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
/*
* Skip the native system next time through.
*/
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
- if (proc != NULL) {
- startAt = (*proc)(interp, pathPtr, startAt);
- }
+ if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
+ continue;
+ }
- /*
- * We could add an efficiency check like this:
- * if (retVal == length-of(pathPtr)) {break;}
- * but there's not much benefit.
- */
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
}
- fsRecPtr = fsRecPtr->nextPtr;
+
+ /*
+ * We could add an efficiency check like this:
+ * if (retVal == length-of(pathPtr)) {break;}
+ * but there's not much benefit.
+ */
}
return startAt;
@@ -1526,7 +1470,7 @@ TclGetOpenModeEx(
* EOF during the opening of the file. */
int *binaryPtr) /* Set this to 1 if the caller should
* configure the opened channel for binary
- * operations */
+ * operations. */
{
int mode, modeArgc, c, i, gotRW;
const char **modeArgv, *flag;
@@ -1568,7 +1512,7 @@ TclGetOpenModeEx(
default:
goto error;
}
- i=1;
+ i = 1;
while (i<3 && modeString[i]) {
if (modeString[i] == modeString[i-1]) {
goto error;
@@ -1652,7 +1596,7 @@ TclGetOpenModeEx(
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", NULL);
}
- ckfree((char *) modeArgv);
+ ckfree(modeArgv);
return -1;
#endif
@@ -1664,7 +1608,7 @@ TclGetOpenModeEx(
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", NULL);
}
- ckfree((char *) modeArgv);
+ ckfree(modeArgv);
return -1;
#endif
@@ -1679,12 +1623,12 @@ TclGetOpenModeEx(
"\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
"CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);
}
- ckfree((char *) modeArgv);
+ ckfree(modeArgv);
return -1;
}
}
- ckfree((char *) modeArgv);
+ ckfree(modeArgv);
if (!gotRW) {
if (interp != NULL) {
@@ -1697,25 +1641,13 @@ TclGetOpenModeEx(
}
/*
- * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
- */
-
-int
-Tcl_FSEvalFile(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution
- * will be performed on this name. */
-{
- return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
-}
-
-/*
*----------------------------------------------------------------------
*
- * Tcl_FSEvalFileEx --
+ * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
* Read in a file and process the entire file as one gigantic Tcl
- * command.
+ * command. Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
+ * TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
* A standard Tcl result, which is either the result of executing the
@@ -1730,6 +1662,15 @@ Tcl_FSEvalFile(
*/
int
+Tcl_FSEvalFile(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution
+ * will be performed on this name. */
+{
+ return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
+}
+
+int
Tcl_FSEvalFileEx(
Tcl_Interp *interp, /* Interpreter in which to process file. */
Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution
@@ -1741,7 +1682,7 @@ Tcl_FSEvalFileEx(
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
- char *string;
+ const char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
@@ -1756,7 +1697,7 @@ Tcl_FSEvalFileEx(
return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
- if (chan == (Tcl_Channel) NULL) {
+ if (chan == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
@@ -1801,8 +1742,11 @@ Tcl_FSEvalFileEx(
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
- /* TIP #280 Force the evaluator to open a frame for a sourced
- * file. */
+
+ /*
+ * TIP #280 Force the evaluator to open a frame for a sourced file.
+ */
+
iPtr->evalFlags |= TCL_EVAL_FILE;
result = Tcl_EvalEx(interp, string, length, 0);
@@ -1831,13 +1775,138 @@ Tcl_FSEvalFileEx(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : length), pathString,
- (overflow ? "..." : ""), interp->errorLine));
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
+
+int
+TclNREvalFile(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution
+ * will be performed on this name. */
+ const char *encodingName) /* If non-NULL, then use this encoding for the
+ * file. NULL means use the system encoding. */
+{
+ Tcl_StatBuf statBuf;
+ Tcl_Obj *oldScriptFile, *objPtr;
+ Interp *iPtr;
+ Tcl_Channel chan;
+
+ if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
+ Tcl_SetErrno(errno);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
+ if (chan == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
+ * this cross-platform to allow for scripted documents. [Bug: 2040]
+ */
+
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+
+ /*
+ * If the encoding is specified, set it for the channel. Else don't touch
+ * it (and use the system encoding) Report error on unknown encoding.
+ */
+
+ if (encodingName != NULL) {
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp,chan);
+ return TCL_ERROR;
+ }
+ }
+
+ objPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(objPtr);
+ if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
+ Tcl_Close(interp, chan);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_Close(interp, chan) != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ iPtr = (Interp *) interp;
+ oldScriptFile = iPtr->scriptFile;
+ iPtr->scriptFile = pathPtr;
+ Tcl_IncrRefCount(iPtr->scriptFile);
+
+ /*
+ * TIP #280: Force the evaluator to open a frame for a sourced file.
+ */
+
+ iPtr->evalFlags |= TCL_EVAL_FILE;
+ TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
+ NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN);
+}
+
+static int
+EvalFileCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *oldScriptFile = data[0];
+ Tcl_Obj *pathPtr = data[1];
+ Tcl_Obj *objPtr = data[2];
+
+ /*
+ * Now we have to be careful; the script may have changed the
+ * iPtr->scriptFile value, so we must reset it without assuming it still
+ * points to 'pathPtr'.
+ */
+
+ if (iPtr->scriptFile != NULL) {
+ Tcl_DecrRefCount(iPtr->scriptFile);
+ }
+ iPtr->scriptFile = oldScriptFile;
+
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ } else if (result == TCL_ERROR) {
+ /*
+ * Record information telling where the error occurred.
+ */
+
+ int length;
+ const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ const int limit = 150;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (file \"%.*s%s\" line %d)",
+ (overflow ? limit : length), pathString,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ }
+
+ Tcl_DecrRefCount(objPtr);
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -1861,6 +1930,11 @@ Tcl_FSEvalFileEx(
int
Tcl_GetErrno(void)
{
+ /*
+ * On some platforms, errno is really a thread local (implemented by the C
+ * library).
+ */
+
return errno;
}
@@ -1869,7 +1943,9 @@ Tcl_GetErrno(void)
*
* Tcl_SetErrno --
*
- * Sets the Tcl error code variable to the supplied value.
+ * Sets the Tcl error code variable to the supplied value. On some saner
+ * platforms this is actually a thread-local (this is implemented in the
+ * C library) but this is *really* unsafe to assume!
*
* Results:
* None.
@@ -1884,6 +1960,11 @@ void
Tcl_SetErrno(
int err) /* The new value. */
{
+ /*
+ * On some platforms, errno is really a thread local (implemented by the C
+ * library).
+ */
+
errno = err;
}
@@ -1945,72 +2026,10 @@ Tcl_FSStat(
Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
- const Tcl_Filesystem *fsPtr;
-#ifdef USE_OBSOLETE_FS_HOOKS
- struct stat oldStyleStatBuffer;
- int retVal = -1;
-
- /*
- * Call each of the "stat" function in succession. A non-return value of
- * -1 indicates the particular function has succeeded.
- */
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
-
- if (statProcList != NULL) {
- StatProc *statProcPtr;
- char *path;
- Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
- if (transPtr == NULL) {
- path = NULL;
- } else {
- path = Tcl_GetString(transPtr);
- }
-
- statProcPtr = statProcList;
- while ((retVal == -1) && (statProcPtr != NULL)) {
- retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
- statProcPtr = statProcPtr->nextPtr;
- }
- if (transPtr != NULL) {
- Tcl_DecrRefCount(transPtr);
- }
- }
-
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
- if (retVal != -1) {
- /*
- * Note that EOVERFLOW is not a problem here, and these assignments
- * should all be widening (if not identity.)
- */
-
- buf->st_mode = oldStyleStatBuffer.st_mode;
- buf->st_ino = oldStyleStatBuffer.st_ino;
- buf->st_dev = oldStyleStatBuffer.st_dev;
- buf->st_rdev = oldStyleStatBuffer.st_rdev;
- buf->st_nlink = oldStyleStatBuffer.st_nlink;
- buf->st_uid = oldStyleStatBuffer.st_uid;
- buf->st_gid = oldStyleStatBuffer.st_gid;
- buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
- buf->st_atime = oldStyleStatBuffer.st_atime;
- buf->st_mtime = oldStyleStatBuffer.st_mtime;
- buf->st_ctime = oldStyleStatBuffer.st_ctime;
-#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- buf->st_blksize = oldStyleStatBuffer.st_blksize;
-#endif
-#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
-#endif
- return retVal;
- }
-#endif /* USE_OBSOLETE_FS_HOOKS */
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSStatProc *proc = fsPtr->statProc;
- if (proc != NULL) {
- return (*proc)(pathPtr, buf);
- }
+ if (fsPtr != NULL && fsPtr->statProc != NULL) {
+ return fsPtr->statProc(pathPtr, buf);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -2041,15 +2060,13 @@ Tcl_FSLstat(
Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr != NULL) {
- Tcl_FSLstatProc *proc = fsPtr->lstatProc;
- if (proc != NULL) {
- return (*proc)(pathPtr, buf);
- } else {
- Tcl_FSStatProc *sproc = fsPtr->statProc;
- if (sproc != NULL) {
- return (*sproc)(pathPtr, buf);
- }
+ if (fsPtr->lstatProc != NULL) {
+ return fsPtr->lstatProc(pathPtr, buf);
+ }
+ if (fsPtr->statProc != NULL) {
+ return fsPtr->statProc(pathPtr, buf);
}
}
Tcl_SetErrno(ENOENT);
@@ -2078,51 +2095,11 @@ Tcl_FSAccess(
Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
int mode) /* Permission setting. */
{
- const Tcl_Filesystem *fsPtr;
-#ifdef USE_OBSOLETE_FS_HOOKS
- int retVal = -1;
-
- /*
- * Call each of the "access" function in succession. A non-return value of
- * -1 indicates the particular function has succeeded.
- */
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
-
- if (accessProcList != NULL) {
- AccessProc *accessProcPtr;
- char *path;
- Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
- if (transPtr == NULL) {
- path = NULL;
- } else {
- path = Tcl_GetString(transPtr);
- }
-
- accessProcPtr = accessProcList;
- while ((retVal == -1) && (accessProcPtr != NULL)) {
- retVal = (*accessProcPtr->proc)(path, mode);
- accessProcPtr = accessProcPtr->nextPtr;
- }
- if (transPtr != NULL) {
- Tcl_DecrRefCount(transPtr);
- }
- }
-
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
- if (retVal != -1) {
- return retVal;
- }
-#endif /* USE_OBSOLETE_FS_HOOKS */
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSAccessProc *proc = fsPtr->accessProc;
- if (proc != NULL) {
- return (*proc)(pathPtr, mode);
- }
+ if (fsPtr != NULL && fsPtr->accessProc != NULL) {
+ return fsPtr->accessProc(pathPtr, mode);
}
-
Tcl_SetErrno(ENOENT);
return -1;
}
@@ -2158,41 +2135,6 @@ Tcl_FSOpenFileChannel(
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
-#ifdef USE_OBSOLETE_FS_HOOKS
- /*
- * Call each of the "Tcl_OpenFileChannel" functions in succession. A
- * non-NULL return value indicates the particular function has succeeded.
- */
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
- if (openFileChannelProcList != NULL) {
- OpenFileChannelProc *openFileChannelProcPtr;
- char *path;
- Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
-
- if (transPtr == NULL) {
- path = NULL;
- } else {
- path = Tcl_GetString(transPtr);
- }
-
- openFileChannelProcPtr = openFileChannelProcList;
-
- while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
- retVal = (*openFileChannelProcPtr->proc)(interp, path,
- modeString, permissions);
- openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
- }
- if (transPtr != NULL) {
- Tcl_DecrRefCount(transPtr);
- }
- }
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
- if (retVal != NULL) {
- return retVal;
- }
-#endif /* USE_OBSOLETE_FS_HOOKS */
-
/*
* We need this just to ensure we return the correct error messages under
* some circumstances.
@@ -2203,49 +2145,47 @@ Tcl_FSOpenFileChannel(
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
- if (proc != NULL) {
- int mode, seekFlag, binary;
+ if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) {
+ int mode, seekFlag, binary;
- /*
- * Parse the mode, picking up whether we want to seek to start
- * with and/or set the channel automatically into binary mode.
- */
+ /*
+ * Parse the mode, picking up whether we want to seek to start with
+ * and/or set the channel automatically into binary mode.
+ */
- mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
- if (mode == -1) {
- return NULL;
- }
+ mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
+ if (mode == -1) {
+ return NULL;
+ }
- /*
- * Do the actual open() call.
- */
+ /*
+ * Do the actual open() call.
+ */
- retVal = (*proc)(interp, pathPtr, mode, permissions);
- if (retVal == NULL) {
- return NULL;
- }
+ retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
+ permissions);
+ if (retVal == NULL) {
+ return NULL;
+ }
- /*
- * Apply appropriate flags parsed out above.
- */
+ /*
+ * Apply appropriate flags parsed out above.
+ */
- if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0,
- SEEK_END) < (Tcl_WideInt)0) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "could not seek to end "
- "of file while opening \"", Tcl_GetString(pathPtr),
- "\": ", Tcl_PosixError(interp), NULL);
- }
- Tcl_Close(NULL, retVal);
- return NULL;
- }
- if (binary) {
- Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
+ if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
+ < (Tcl_WideInt) 0) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "could not seek to end of file "
+ "while opening \"", Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), NULL);
}
- return retVal;
+ Tcl_Close(NULL, retVal);
+ return NULL;
+ }
+ if (binary) {
+ Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
}
+ return retVal;
}
/*
@@ -2279,17 +2219,17 @@ Tcl_FSOpenFileChannel(
int
Tcl_FSUtime(
- Tcl_Obj *pathPtr, /* File to change access/modification times */
+ Tcl_Obj *pathPtr, /* File to change access/modification
+ * times. */
struct utimbuf *tval) /* Structure containing access/modification
* times to use. Should not be modified. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
- if (proc != NULL) {
- return (*proc)(pathPtr, tval);
- }
+
+ if (fsPtr != NULL && fsPtr->utimeProc != NULL) {
+ return fsPtr->utimeProc(pathPtr, tval);
}
+ /* TODO: set errno here? Tcl_SetErrno(ENOENT); */
return -1;
}
@@ -2313,7 +2253,7 @@ Tcl_FSUtime(
*----------------------------------------------------------------------
*/
-static const char **
+static const char *const *
NativeFileAttrStrings(
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
@@ -2350,8 +2290,7 @@ NativeFileAttrsGet(
Tcl_Obj *pathPtr, /* path of file we are operating on. */
Tcl_Obj **objPtrRef) /* for output. */
{
- return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr,
- objPtrRef);
+ return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef);
}
/*
@@ -2380,7 +2319,7 @@ NativeFileAttrsSet(
Tcl_Obj *pathPtr, /* path of file we are operating on. */
Tcl_Obj *objPtr) /* set to this value. */
{
- return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr);
+ return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr);
}
/*
@@ -2407,18 +2346,15 @@ NativeFileAttrsSet(
*----------------------------------------------------------------------
*/
-const char **
+const char *const *
Tcl_FSFileAttrStrings(
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
- if (proc != NULL) {
- return (*proc)(pathPtr, objPtrRef);
- }
+ if (fsPtr != NULL && fsPtr->fileAttrStringsProc != NULL) {
+ return fsPtr->fileAttrStringsProc(pathPtr, objPtrRef);
}
Tcl_SetErrno(ENOENT);
return NULL;
@@ -2449,7 +2385,7 @@ TclFSFileAttrIndex(
int *indexPtr) /* Where to write the found index. */
{
Tcl_Obj *listObj = NULL;
- const char **attrTable;
+ const char *const *attrTable;
/*
* Get the attribute table for the file.
@@ -2531,11 +2467,8 @@ Tcl_FSFileAttrsGet(
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
- if (proc != NULL) {
- return (*proc)(interp, index, pathPtr, objPtrRef);
- }
+ if (fsPtr != NULL && fsPtr->fileAttrsGetProc != NULL) {
+ return fsPtr->fileAttrsGetProc(interp, index, pathPtr, objPtrRef);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -2568,11 +2501,8 @@ Tcl_FSFileAttrsSet(
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
- if (proc != NULL) {
- return (*proc)(interp, index, pathPtr, objPtr);
- }
+ if (fsPtr != NULL && fsPtr->fileAttrsSetProc != NULL) {
+ return fsPtr->fileAttrsSetProc(interp, index, pathPtr, objPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -2633,55 +2563,58 @@ Tcl_FSGetCwd(
* indicates the particular function has succeeded.
*/
- fsRecPtr = FsGetFirstFilesystem();
- while ((retVal == NULL) && (fsRecPtr != NULL)) {
- Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
- if (proc != NULL) {
- if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
- ClientData retCd;
- TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
-
- retCd = (*proc2)(NULL);
- if (retCd != NULL) {
- Tcl_Obj *norm;
- /* Looks like a new current directory */
- retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(
- retCd);
- Tcl_IncrRefCount(retVal);
- norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
- if (norm != NULL) {
- /*
- * We found a cwd, which is now in our global
- * storage. We must make a copy. Norm already has
- * a refCount of 1.
- *
- * Threading issue: note that multiple threads at
- * system startup could in principle call this
- * function simultaneously. They will therefore
- * each set the cwdPathPtr independently. That
- * behaviour is a bit peculiar, but should be
- * fine. Once we have a cwd, we'll always be in
- * the 'else' branch below which is simpler.
- */
-
- FsUpdateCwd(norm, retCd);
- Tcl_DecrRefCount(norm);
- } else {
- (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
- }
- Tcl_DecrRefCount(retVal);
- retVal = NULL;
- goto cdDidNotChange;
- } else if (interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
- }
+ for (fsRecPtr = FsGetFirstFilesystem();
+ (retVal == NULL) && (fsRecPtr != NULL);
+ fsRecPtr = fsRecPtr->nextPtr) {
+ ClientData retCd;
+ TclFSGetCwdProc2 *proc2;
+ if (fsRecPtr->fsPtr->getCwdProc == NULL) {
+ continue;
+ }
+
+ if (fsRecPtr->fsPtr->version == TCL_FILESYSTEM_VERSION_1) {
+ retVal = fsRecPtr->fsPtr->getCwdProc(interp);
+ continue;
+ }
+
+ proc2 = (TclFSGetCwdProc2 *) fsRecPtr->fsPtr->getCwdProc;
+ retCd = proc2(NULL);
+ if (retCd != NULL) {
+ Tcl_Obj *norm;
+
+ /*
+ * Looks like a new current directory.
+ */
+
+ retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
+ Tcl_IncrRefCount(retVal);
+ norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
+ if (norm != NULL) {
+ /*
+ * We found a cwd, which is now in our global storage. We
+ * must make a copy. Norm already has a refCount of 1.
+ *
+ * Threading issue: note that multiple threads at system
+ * startup could in principle call this function
+ * simultaneously. They will therefore each set the
+ * cwdPathPtr independently. That behaviour is a bit
+ * peculiar, but should be fine. Once we have a cwd, we'll
+ * always be in the 'else' branch below which is simpler.
+ */
+
+ FsUpdateCwd(norm, retCd);
+ Tcl_DecrRefCount(norm);
} else {
- retVal = (*proc)(interp);
+ fsRecPtr->fsPtr->freeInternalRepProc(retCd);
}
+ Tcl_DecrRefCount(retVal);
+ retVal = NULL;
+ goto cdDidNotChange;
+ } else if (interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), NULL);
}
- fsRecPtr = fsRecPtr->nextPtr;
}
/*
@@ -2695,6 +2628,7 @@ Tcl_FSGetCwd(
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+
if (norm != NULL) {
/*
* We found a cwd, which is now in our global storage. We must
@@ -2709,6 +2643,7 @@ Tcl_FSGetCwd(
*/
ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
+
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
@@ -2722,7 +2657,10 @@ Tcl_FSGetCwd(
* the permissions on that directory have changed.
*/
- const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
+ const Tcl_Filesystem *fsPtr =
+ Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
+ ClientData retCd = NULL;
+ Tcl_Obj *retVal, *norm;
/*
* If the filesystem couldn't be found, or if no cwd function exists
@@ -2733,94 +2671,98 @@ Tcl_FSGetCwd(
* (This is tested for in the test suite on unix).
*/
- if (fsPtr != NULL) {
- Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
- ClientData retCd = NULL;
- if (proc != NULL) {
- Tcl_Obj *retVal;
- if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
- TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
-
- retCd = (*proc2)(tsdPtr->cwdClientData);
- if (retCd == NULL && interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
- }
+ if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
+ goto cdDidNotChange;
+ }
- if (retCd == tsdPtr->cwdClientData) {
- goto cdDidNotChange;
- }
+ if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) {
+ retVal = fsPtr->getCwdProc(interp);
+ } else {
+ /*
+ * New API.
+ */
- /*
- * Looks like a new current directory.
- */
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
- retVal = (*fsPtr->internalToNormalizedProc)(retCd);
- Tcl_IncrRefCount(retVal);
- } else {
- retVal = (*proc)(interp);
- }
- if (retVal != NULL) {
- Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp,
- retVal, NULL);
+ retCd = proc2(tsdPtr->cwdClientData);
+ if (retCd == NULL && interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), NULL);
+ }
- /*
- * Check whether cwd has changed from the value previously
- * stored in cwdPathPtr. Really 'norm' shouldn't be NULL,
- * but we are careful.
- */
+ if (retCd == tsdPtr->cwdClientData) {
+ goto cdDidNotChange;
+ }
- if (norm == NULL) {
- /* Do nothing */
- if (retCd != NULL) {
- (*fsPtr->freeInternalRepProc)(retCd);
- }
- } else if (norm == tsdPtr->cwdPathPtr) {
- goto cdEqual;
- } else {
- /*
- * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are
- * normalized paths. Therefore we can be more
- * efficient than calling 'Tcl_FSEqualPaths', and in
- * addition avoid a nasty infinite loop bug when
- * trying to normalize tsdPtr->cwdPathPtr.
- */
-
- int len1, len2;
- char *str1, *str2;
-
- str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = Tcl_GetStringFromObj(norm, &len2);
- if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
- /*
- * If the paths were equal, we can be more
- * efficient and retain the old path object which
- * will probably already be shared. In this case
- * we can simply free the normalized path we just
- * calculated.
- */
-
- cdEqual:
- Tcl_DecrRefCount(norm);
- if (retCd != NULL) {
- (*fsPtr->freeInternalRepProc)(retCd);
- }
- } else {
- FsUpdateCwd(norm, retCd);
- Tcl_DecrRefCount(norm);
- }
- }
- Tcl_DecrRefCount(retVal);
- } else {
- /*
- * The 'cwd' function returned an error; reset the cwd.
- */
+ /*
+ * Looks like a new current directory.
+ */
+
+ retVal = fsPtr->internalToNormalizedProc(retCd);
+ Tcl_IncrRefCount(retVal);
+ }
+
+ /*
+ * Check if the 'cwd' function returned an error; if so, reset the
+ * cwd.
+ */
+
+ if (retVal == NULL) {
+ FsUpdateCwd(NULL, NULL);
+ goto cdDidNotChange;
+ }
+
+ /*
+ * Normalize the path.
+ */
+
+ norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+
+ /*
+ * Check whether cwd has changed from the value previously stored in
+ * cwdPathPtr. Really 'norm' shouldn't be NULL, but we are careful.
+ */
+
+ if (norm == NULL) {
+ /* Do nothing */
+ if (retCd != NULL) {
+ fsPtr->freeInternalRepProc(retCd);
+ }
+ } else if (norm == tsdPtr->cwdPathPtr) {
+ goto cdEqual;
+ } else {
+ /*
+ * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are normalized
+ * paths. Therefore we can be more efficient than calling
+ * 'Tcl_FSEqualPaths', and in addition avoid a nasty infinite loop
+ * bug when trying to normalize tsdPtr->cwdPathPtr.
+ */
+
+ int len1, len2;
+ const char *str1, *str2;
- FsUpdateCwd(NULL, NULL);
+ str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = Tcl_GetStringFromObj(norm, &len2);
+ if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
+ /*
+ * If the paths were equal, we can be more efficient and
+ * retain the old path object which will probably already be
+ * shared. In this case we can simply free the normalized path
+ * we just calculated.
+ */
+
+ cdEqual:
+ Tcl_DecrRefCount(norm);
+ if (retCd != NULL) {
+ fsPtr->freeInternalRepProc(retCd);
}
+ } else {
+ FsUpdateCwd(norm, retCd);
+ Tcl_DecrRefCount(norm);
}
}
+ Tcl_DecrRefCount(retVal);
}
cdDidNotChange:
@@ -2865,14 +2807,13 @@ Tcl_FSChdir(
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
- Tcl_FSChdirProc *proc = fsPtr->chdirProc;
- if (proc != NULL) {
+ if (fsPtr->chdirProc != NULL) {
/*
* If this fails, an appropriate errno will have been stored using
* 'Tcl_SetErrno()'.
*/
- retVal = (*proc)(pathPtr);
+ retVal = fsPtr->chdirProc(pathPtr);
} else {
/*
* Fallback on stat-based implementation.
@@ -2884,7 +2825,7 @@ Tcl_FSChdir(
* If the file can be stat'ed and is a directory and is readable,
* then we can chdir. If any of these actions fail, then
* 'Tcl_SetErrno()' should automatically have been called to set
- * an appropriate error code
+ * an appropriate error code.
*/
if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
@@ -2906,9 +2847,7 @@ Tcl_FSChdir(
* was no error we must assume that the cwd was actually changed to the
* normalized value we calculated above, and we must therefore cache that
* information.
- */
-
- /*
+ *
* If the filesystem in question has a getCwdProc, then the correct logic
* which performs the part below is already part of the Tcl_FSGetCwd()
* call, so no need to replicate it again. This will have a side effect
@@ -2968,8 +2907,9 @@ Tcl_FSChdir(
* Assumption we are using a filesystem version 2.
*/
- TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
- cd = (*proc2)(oldcd);
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
+
+ cd = proc2(oldcd);
if (cd != oldcd) {
FsUpdateCwd(normDirName, cd);
}
@@ -3028,9 +2968,8 @@ Tcl_FSLoadFile(
* function which should be used for this
* file. */
{
- const char *symbols[2];
- Tcl_PackageInitProc **procPtrs[2];
- ClientData clientData;
+ const char *symbols[3];
+ void *procPtrs[2];
int res;
/*
@@ -3039,35 +2978,27 @@ Tcl_FSLoadFile(
symbols[0] = sym1;
symbols[1] = sym2;
- procPtrs[0] = proc1Ptr;
- procPtrs[1] = proc2Ptr;
+ symbols[2] = NULL;
/*
* Perform the load.
*/
- res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr,
- &clientData, unloadProcPtr);
-
- /*
- * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared
- * library, we don't keep the loadHandle (for TclpFindSymbol) and the
- * clientData (for the unloadProc) separately. In fact we effectively
- * throw away the loadHandle and only use the clientData. It just so
- * happens, for the native filesystem only, that these two are identical.
- *
- * This also means that the signatures Tcl_FSUnloadFileProc and
- * Tcl_FSLoadFileProc are both misleading.
- */
+ res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr);
+ if (res == TCL_OK) {
+ *proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0];
+ *proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1];
+ } else {
+ *proc1Ptr = *proc2Ptr = NULL;
+ }
- *handlePtr = (Tcl_LoadHandle) clientData;
return res;
}
/*
*----------------------------------------------------------------------
*
- * TclLoadFile --
+ * Tcl_LoadFile --
*
* Dynamically loads a binary code file into memory and returns the
* addresses of a number of given functions within that file, if they are
@@ -3081,74 +3012,56 @@ Tcl_FSLoadFile(
* filesystems (and has other problems documented in the load man-page),
* so it is advised that full paths are always used.
*
- * This function is currently private to Tcl. It may be exported in the
- * future and its interface fixed (but we should clean up the
- * loadHandle/clientData confusion at that time -- see the above comments
- * in Tcl_FSLoadFile for details). For a public function, see
- * Tcl_FSLoadFile.
- *
* Results:
* A standard Tcl completion code. If an error occurs, an error message
* is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory. This may later be unloaded by
- * passing the clientData to the unloadProc.
+ * calling TclFS_UnloadFile.
*
*----------------------------------------------------------------------
*/
int
-TclLoadFile(
+Tcl_LoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code. */
- int symc, /* Number of symbols/procPtrs in the next two
- * arrays. */
- const char *symbols[], /* Names of functions to look up in the file's
+ const char *const symbols[],/* Names of functions to look up in the file's
* symbol table. */
- Tcl_PackageInitProc **procPtrs[],
- /* Where to return the addresses corresponding
+ int flags, /* Flags (unused) */
+ void *procVPtrs, /* Where to return the addresses corresponding
* to symbols[]. */
- Tcl_LoadHandle *handlePtr, /* Filled with token for shared library
+ Tcl_LoadHandle *handlePtr) /* Filled with token for shared library
* information which can be used in
* TclpFindSymbol. */
- ClientData *clientDataPtr, /* Filled with token for dynamically loaded
- * file which will be passed back to
- * (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr)
- /* Filled with address of Tcl_FSUnloadFileProc
- * function which should be used for this
- * file. */
{
+ void **procPtrs = (void **) procVPtrs;
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- Tcl_FSLoadFileProc *proc;
- Tcl_Filesystem *copyFsPtr;
+ const Tcl_Filesystem *copyFsPtr;
+ Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *copyToPtr;
Tcl_LoadHandle newLoadHandle = NULL;
- ClientData newClientData = NULL;
+ Tcl_LoadHandle divertedLoadHandle = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;
int retVal;
+ int i;
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
- proc = fsPtr->loadFileProc;
- if (proc != NULL) {
- int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
+ if (fsPtr->loadFileProc != NULL) {
+ int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr,
+ &unloadProcPtr);
+
if (retVal == TCL_OK) {
if (*handlePtr == NULL) {
return TCL_ERROR;
}
-
- /*
- * Copy this across, since both are equal for the native fs.
- */
-
- *clientDataPtr = (ClientData)*handlePtr;
Tcl_ResetResult(interp);
goto resolveSymbols;
}
@@ -3208,9 +3121,8 @@ TclLoadFile(
ret = Tcl_Read(data, buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
- unloadProcPtr);
+ &unloadProcPtr);
if (ret == TCL_OK && *handlePtr != NULL) {
- *clientDataPtr = (ClientData) *handlePtr;
goto resolveSymbols;
}
}
@@ -3224,12 +3136,7 @@ TclLoadFile(
* to load.
*/
- copyToPtr = TclpTempFileName();
- if (copyToPtr == NULL) {
- Tcl_AppendResult(interp, "couldn't create temporary file: ",
- Tcl_PosixError(interp), NULL);
- return TCL_ERROR;
- }
+ copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
@@ -3242,7 +3149,8 @@ TclLoadFile(
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
- Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL);
+ Tcl_AppendResult(interp, "couldn't load from current filesystem",
+ NULL);
return TCL_ERROR;
}
@@ -3256,7 +3164,7 @@ TclLoadFile(
return TCL_ERROR;
}
-#if !defined(__WIN32__)
+#ifndef __WIN32__
/*
* Do we need to set appropriate permissions on the file? This may be
* required on some systems. On Unix we could loop over the file
@@ -3284,8 +3192,8 @@ TclLoadFile(
Tcl_ResetResult(interp);
- retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs,
- &newLoadHandle, &newClientData, &newUnloadProcPtr);
+ retVal = Tcl_LoadFile(interp, copyToPtr, symbols, 0, procPtrs,
+ &newLoadHandle);
if (retVal != TCL_OK) {
/*
* The file didn't load successfully.
@@ -3311,9 +3219,7 @@ TclLoadFile(
* handle and unload proc ptr.
*/
- (*handlePtr) = newLoadHandle;
- (*clientDataPtr) = newClientData;
- (*unloadProcPtr) = newUnloadProcPtr;
+ *handlePtr = newLoadHandle;
Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -3323,7 +3229,7 @@ TclLoadFile(
* unload and cleanup the temporary file correctly.
*/
- tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));
+ tvdlPtr = ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information. This allows us to cleanup the
@@ -3368,28 +3274,158 @@ TclLoadFile(
}
copyToPtr = NULL;
- (*handlePtr) = newLoadHandle;
- (*clientDataPtr) = (ClientData) tvdlPtr;
- (*unloadProcPtr) = TclFSUnloadTempFile;
+
+ divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_));
+ divertedLoadHandle->clientData = tvdlPtr;
+ divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
+ divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
+ *handlePtr = divertedLoadHandle;
Tcl_ResetResult(interp);
return retVal;
resolveSymbols:
- {
- int i;
+ /*
+ * At this point, *handlePtr is already set up to the handle for the
+ * loaded library. We now try to resolve the symbols.
+ */
+
+ if (symbols != NULL) {
+ for (i=0 ; symbols[i] != NULL; i++) {
+ procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]);
+ if (procPtrs[i] == NULL) {
+ /*
+ * At least one symbol in the list was not found. Unload the
+ * file, and report the problem back to the caller.
+ * (Tcl_FindSymbol should already have left an appropriate
+ * error message.)
+ */
- for (i=0 ; i<symc ; i++) {
- if (symbols[i] != NULL) {
- *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]);
+ (*handlePtr)->unloadFileProcPtr(*handlePtr);
+ *handlePtr = NULL;
+ return TCL_ERROR;
}
}
}
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DivertFindSymbol --
+ *
+ * Find a symbol in a shared library loaded by copy-from-VFS.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void *
+DivertFindSymbol(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_LoadHandle loadHandle, /* Handle to the diverted module */
+ const char *symbol) /* Symbol to resolve */
+{
+ FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
+ Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
+
+ return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DivertUnloadFile --
+ *
+ * Unloads a file that has been loaded by copying from VFS to the native
+ * filesystem.
+ *
+ * Parameters:
+ * loadHandle -- Handle of the file to unload
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DivertUnloadFile(
+ Tcl_LoadHandle loadHandle)
+{
+ FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
+ Tcl_LoadHandle originalHandle;
+
+ /*
+ * This test should never trigger, since we give the client data in the
+ * function above.
+ */
+
+ if (tvdlPtr == NULL) {
+ return;
+ }
+ originalHandle = tvdlPtr->loadHandle;
+
+ /*
+ * Call the real 'unloadfile' proc we actually used. It is very important
+ * that we call this first, so that the shared library is actually
+ * unloaded by the OS. Otherwise, the following 'delete' may well fail
+ * because the shared library is still in use.
+ */
+
+ originalHandle->unloadFileProcPtr(originalHandle);
+
+ /*
+ * What filesystem contains the temp copy of the library?
+ */
+
+ if (tvdlPtr->divertedFilesystem == NULL) {
+ /*
+ * It was the native filesystem, and we have a special function
+ * available just for this purpose, which we know works even at this
+ * late stage.
+ */
+
+ TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
+ NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
+ } else {
+ /*
+ * Remove the temporary file we created. Note, we may crash here
+ * because encodings have been taken down already.
+ */
+
+ if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
+ != TCL_OK) {
+ /*
+ * The above may have failed because the filesystem, or something
+ * it depends upon (e.g. encodings) have been taken down because
+ * Tcl is exiting.
+ *
+ * We may need to work out how to delete this file more robustly
+ * (or give the filesystem the information it needs to delete the
+ * file more robustly).
+ *
+ * In particular, one problem might be that the filesystem cannot
+ * extract the information it needs from the above path object
+ * because Tcl's entire filesystem apparatus (the code in this
+ * file) has been finalized, and it refuses to pass the internal
+ * representation to the filesystem.
+ */
+ }
+
+ /*
+ * And free up the allocations. This will also of course remove a
+ * refCount from the Tcl_Filesystem to which this file belongs, which
+ * could then free up the filesystem if we are exiting.
+ */
+
+ Tcl_DecrRefCount(tvdlPtr->divertedFile);
+ }
+
+ ckfree(tvdlPtr);
+ ckfree(loadHandle);
+}
+
/*
* This function used to be in the platform specific directories, but it has
- * now been made to work cross-platform
+ * now been made to work cross-platform.
*/
int
@@ -3397,7 +3433,7 @@ TclpLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
- const char *sym1, CONST char *sym2,
+ const char *sym1, const char *sym2,
/* Names of two functions to look up in the
* file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
@@ -3424,15 +3460,91 @@ TclpLoadFile(
return TCL_ERROR;
}
- *clientDataPtr = (ClientData) handle;
+ *clientDataPtr = handle;
- *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
- *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
+ *proc1Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym1);
+ *proc2Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym2);
return TCL_OK;
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindSymbol --
+ *
+ * Find a symbol in a loaded library
+ *
+ * Results:
+ * Returns a pointer to the symbol if found. If not found, returns NULL
+ * and leaves an error message in the interpreter result.
+ *
+ * This function was once filesystem-specific, but has been made portable by
+ * having TclpDlopen return a structure that includes procedure pointers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void *
+Tcl_FindSymbol(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_LoadHandle loadHandle, /* Handle to the loaded library */
+ const char *symbol) /* Name of the symbol to resolve */
+{
+ return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSUnloadFile --
+ *
+ * Unloads a library given its handle. Checks first that the library
+ * supports unloading.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSUnloadFile(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_LoadHandle handle) /* Handle of the file to unload */
+{
+ if (handle->unloadFileProcPtr == NULL) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot unload: filesystem does not support unloading",
+ -1));
+ }
+ return TCL_ERROR;
+ }
+ TclpUnloadFile(handle);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpUnloadFile --
+ *
+ * Unloads a library given its handle
+ *
+ * This function was once filesystem-specific, but has been made portable by
+ * having TclpDlopen return a structure that includes procedure pointers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpUnloadFile(
+ Tcl_LoadHandle handle)
+{
+ if (handle->unloadFileProcPtr != NULL) {
+ handle->unloadFileProcPtr(handle);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
*
* TclFSUnloadTempFile --
*
@@ -3447,7 +3559,7 @@ TclpLoadFile(
* The effects of the 'unload' function called, and of course the
* temporary file will be deleted.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
void
@@ -3475,7 +3587,7 @@ TclFSUnloadTempFile(
*/
if (tvdlPtr->unloadProcPtr != NULL) {
- (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
+ tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle);
}
if (tvdlPtr->divertedFilesystem == NULL) {
@@ -3487,7 +3599,6 @@ TclFSUnloadTempFile(
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
-
} else {
/*
* Remove the temporary file we created. Note, we may crash here
@@ -3522,7 +3633,7 @@ TclFSUnloadTempFile(
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
- ckfree((char*)tvdlPtr);
+ ckfree(tvdlPtr);
}
/*
@@ -3560,18 +3671,14 @@ TclFSUnloadTempFile(
Tcl_Obj *
Tcl_FSLink(
- Tcl_Obj *pathPtr, /* Path of file to readlink or link */
- Tcl_Obj *toPtr, /* NULL or path to be linked to */
- int linkAction) /* Action to perform */
+ Tcl_Obj *pathPtr, /* Path of file to readlink or link. */
+ Tcl_Obj *toPtr, /* NULL or path to be linked to. */
+ int linkAction) /* Action to perform. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSLinkProc *proc = fsPtr->linkProc;
-
- if (proc != NULL) {
- return (*proc)(pathPtr, toPtr, linkAction);
- }
+ if (fsPtr != NULL && fsPtr->linkProc != NULL) {
+ return fsPtr->linkProc(pathPtr, toPtr, linkAction);
}
/*
@@ -3583,7 +3690,7 @@ Tcl_FSLink(
*/
#ifndef S_IFLNK
- errno = EINVAL;
+ errno = EINVAL; /* TODO: Change to Tcl_SetErrno()? */
#else
Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
@@ -3615,7 +3722,7 @@ Tcl_FSLink(
*---------------------------------------------------------------------------
*/
-Tcl_Obj*
+Tcl_Obj *
Tcl_FSListVolumes(void)
{
FilesystemRecord *fsRecPtr;
@@ -3630,9 +3737,9 @@ Tcl_FSListVolumes(void)
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
- Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
- if (proc != NULL) {
- Tcl_Obj *thisFsVolumes = (*proc)();
+ if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
+ Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
+
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
Tcl_DecrRefCount(thisFsVolumes);
@@ -3680,15 +3787,13 @@ FsListMounts(
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- Tcl_FSMatchInDirectoryProc *proc =
- fsRecPtr->fsPtr->matchInDirectoryProc;
- if (proc != NULL) {
- if (resultPtr == NULL) {
- resultPtr = Tcl_NewObj();
- }
- (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
+ fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
+ if (resultPtr == NULL) {
+ resultPtr = Tcl_NewObj();
}
+ fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr,
+ pattern, &mountsOnly);
}
fsRecPtr = fsRecPtr->nextPtr;
}
@@ -3722,10 +3827,10 @@ Tcl_FSSplitPath(
int *lenPtr) /* int to store number of path elements. */
{
Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
- Tcl_Filesystem *fsPtr;
+ const Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
- char *p;
+ const char *p;
/*
* Perform platform specific splitting.
@@ -3745,7 +3850,8 @@ Tcl_FSSplitPath(
*/
if (fsPtr->filesystemSeparatorProc != NULL) {
- Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
+ Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
+
if (sep != NULL) {
Tcl_IncrRefCount(sep);
separator = Tcl_GetString(sep)[0];
@@ -3770,14 +3876,16 @@ Tcl_FSSplitPath(
*/
for (;;) {
- char *elementStart = p;
+ const char *elementStart = p;
int length;
+
while ((*p != '\0') && (*p != separator)) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
+
if (elementStart[0] == '~') {
TclNewLiteralStringObj(nextElt, "./");
Tcl_AppendToObj(nextElt, elementStart, length);
@@ -3800,11 +3908,11 @@ Tcl_FSSplitPath(
}
return result;
}
-
-/* Simple helper function */
+
+/* Simple helper function. */
Tcl_Obj *
TclFSInternalToNormalized(
- Tcl_Filesystem *fromFilesystem,
+ const Tcl_Filesystem *fromFilesystem,
ClientData clientData,
FilesystemRecord **fsRecPtrPtr)
{
@@ -3818,12 +3926,11 @@ TclFSInternalToNormalized(
fsRecPtr = fsRecPtr->nextPtr;
}
- if ((fsRecPtr != NULL)
- && (fromFilesystem->internalToNormalizedProc != NULL)) {
- return (*fromFilesystem->internalToNormalizedProc)(clientData);
- } else {
+ if ((fsRecPtr == NULL)
+ || (fromFilesystem->internalToNormalizedProc == NULL)) {
return NULL;
}
+ return fromFilesystem->internalToNormalizedProc(clientData);
}
/*
@@ -3847,8 +3954,8 @@ TclFSInternalToNormalized(
Tcl_PathType
TclGetPathType(
- Tcl_Obj *pathPtr, /* Path to determine type for */
- Tcl_Filesystem **filesystemPtrPtr,
+ Tcl_Obj *pathPtr, /* Path to determine type for. */
+ const Tcl_Filesystem **filesystemPtrPtr,
/* If absolute path and this is not NULL, then
* set to the filesystem which claims this
* path. */
@@ -3862,11 +3969,9 @@ TclGetPathType(
* caller. */
{
int pathLen;
- char *path;
+ const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
- path = Tcl_GetStringFromObj(pathPtr, &pathLen);
-
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
@@ -3904,9 +4009,9 @@ TclGetPathType(
Tcl_PathType
TclFSNonnativePathType(
- const char *path, /* Path to determine type for */
- int pathLen, /* Length of the path */
- Tcl_Filesystem **filesystemPtrPtr,
+ const char *path, /* Path to determine type for. */
+ int pathLen, /* Length of the path. */
+ const Tcl_Filesystem **filesystemPtrPtr,
/* If absolute path and this is not NULL, then
* set to the filesystem which claims this
* path. */
@@ -3930,39 +4035,37 @@ TclFSNonnativePathType(
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
- Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
-
/*
* We want to skip the native filesystem in this loop because
- * otherwise we won't necessarily pass all the Tcl testsuite -- this
- * is because some of the tests artificially change the current
- * platform (between win, unix) but the list of volumes we get by
- * calling (*proc) will reflect the current (real) platform only and
- * this may cause some tests to fail. In particular, on unix '/' will
- * match the beginning of certain absolute Windows paths starting '//'
- * and those tests will go wrong.
+ * otherwise we won't necessarily pass all the Tcl testsuite - this is
+ * because some of the tests artificially change the current platform
+ * (between win, unix) but the list of volumes we get by calling
+ * fsRecPtr->fsPtr->listVolumesProc will reflect the current (real)
+ * platform only and this may cause some tests to fail. In particular,
+ * on Unix '/' will match the beginning of certain absolute Windows
+ * paths starting '//' and those tests will go wrong.
*
* Besides these test-suite issues, there is one other reason to skip
- * the native filesystem --- since the tclFilename.c code has nice
- * fast 'absolute path' checkers, we don't want to waste time
- * repeating that effort here, and this function is actually called
- * quite often, so if we can save the overhead of the native
- * filesystem returning us a list of volumes all the time, it is
- * better.
+ * the native filesystem - since the tclFilename.c code has nice fast
+ * 'absolute path' checkers, we don't want to waste time repeating
+ * that effort here, and this function is actually called quite often,
+ * so if we can save the overhead of the native filesystem returning
+ * us a list of volumes all the time, it is better.
*/
- if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
+ if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
+ && (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
int numVolumes;
- Tcl_Obj *thisFsVolumes = (*proc)();
+ Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
- * This is VERY bad; the Tcl_FSListVolumesProc didn't
- * return a valid list. Set numVolumes to -1 so that we
- * skip the while loop below and just return with the
- * current value of 'type'.
+ * This is VERY bad; the listVolumesProc didn't return a
+ * valid list. Set numVolumes to -1 so that we skip the
+ * while loop below and just return with the current value
+ * of 'type'.
*
* It would be better if we could signal an error here
* (but Tcl_Panic seems a bit excessive).
@@ -3973,7 +4076,7 @@ TclFSNonnativePathType(
while (numVolumes > 0) {
Tcl_Obj *vol;
int len;
- char *strVol;
+ const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
@@ -4001,6 +4104,7 @@ TclFSNonnativePathType(
/*
* We don't need to examine any more filesystems.
*/
+
break;
}
}
@@ -4030,21 +4134,20 @@ TclFSNonnativePathType(
int
Tcl_FSRenameFile(
- Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed
+ Tcl_Obj *srcPathPtr, /* Pathname of file or dir to be renamed
* (UTF-8). */
Tcl_Obj *destPathPtr) /* New pathname of file or directory
* (UTF-8). */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
+
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
- if ((fsPtr == fsPtr2) && (fsPtr != NULL)) {
- Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
- if (proc != NULL) {
- retVal = (*proc)(srcPathPtr, destPathPtr);
- }
+ if ((fsPtr == fsPtr2) && (fsPtr != NULL)
+ && (fsPtr->renameFileProc != NULL)) {
+ retVal = fsPtr->renameFileProc(srcPathPtr, destPathPtr);
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
@@ -4081,14 +4184,12 @@ Tcl_FSCopyFile(
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
+
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
- if (fsPtr == fsPtr2 && fsPtr != NULL) {
- Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
- if (proc != NULL) {
- retVal = (*proc)(srcPathPtr, destPathPtr);
- }
+ if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyFileProc != NULL) {
+ retVal = fsPtr->copyFileProc(srcPathPtr, destPathPtr);
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
@@ -4113,9 +4214,10 @@ Tcl_FSCopyFile(
*
*---------------------------------------------------------------------------
*/
+
int
TclCrossFilesystemCopy(
- Tcl_Interp *interp, /* For error messages */
+ Tcl_Interp *interp, /* For error messages. */
Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */
{
@@ -4195,11 +4297,9 @@ Tcl_FSDeleteFile(
Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
- if (proc != NULL) {
- return (*proc)(pathPtr);
- }
+
+ if (fsPtr != NULL && fsPtr->deleteFileProc != NULL) {
+ return fsPtr->deleteFileProc(pathPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -4227,11 +4327,9 @@ Tcl_FSCreateDirectory(
Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL) {
- Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
- if (proc != NULL) {
- return (*proc)(pathPtr);
- }
+
+ if (fsPtr != NULL && fsPtr->createDirectoryProc != NULL) {
+ return fsPtr->createDirectoryProc(pathPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -4257,7 +4355,7 @@ Tcl_FSCreateDirectory(
int
Tcl_FSCopyDirectory(
- Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied
+ Tcl_Obj *srcPathPtr, /* Pathname of directory to be copied
* (UTF-8). */
Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */
Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new
@@ -4266,14 +4364,12 @@ Tcl_FSCopyDirectory(
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
+
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
- if (fsPtr == fsPtr2 && fsPtr != NULL) {
- Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
- if (proc != NULL) {
- retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
- }
+ if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyDirectoryProc != NULL){
+ retVal = fsPtr->copyDirectoryProc(srcPathPtr, destPathPtr, errorPtr);
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
@@ -4310,45 +4406,46 @@ Tcl_FSRemoveDirectory(
* error, with refCount 1. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) {
- Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
- if (recursive) {
- /*
- * We check whether the cwd lies inside this directory and move it
- * if it does.
- */
- Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
+ if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+
+ /*
+ * When working recursively, we check whether the cwd lies inside this
+ * directory and move it if it does.
+ */
+
+ if (recursive) {
+ Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
- if (cwdPtr != NULL) {
- char *cwdStr, *normPathStr;
- int cwdLen, normLen;
- Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (cwdPtr != NULL) {
+ const char *cwdStr, *normPathStr;
+ int cwdLen, normLen;
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
- if (normPath != NULL) {
- normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
- cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
- if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
- (size_t) normLen) == 0)) {
- /*
- * The cwd is inside the directory, so we perform a
- * 'cd [file dirname $path]'.
- */
+ if (normPath != NULL) {
+ normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
+ cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
+ (size_t) normLen) == 0)) {
+ /*
+ * The cwd is inside the directory, so we perform a 'cd
+ * [file dirname $path]'.
+ */
- Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
- TCL_PATH_DIRNAME);
+ Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
+ TCL_PATH_DIRNAME);
- Tcl_FSChdir(dirPtr);
- Tcl_DecrRefCount(dirPtr);
- }
+ Tcl_FSChdir(dirPtr);
+ Tcl_DecrRefCount(dirPtr);
}
- Tcl_DecrRefCount(cwdPtr);
}
+ Tcl_DecrRefCount(cwdPtr);
}
- return (*proc)(pathPtr, recursive, errorPtr);
}
- Tcl_SetErrno(ENOENT);
- return -1;
+ return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr);
}
/*
@@ -4370,12 +4467,12 @@ Tcl_FSRemoveDirectory(
*---------------------------------------------------------------------------
*/
-Tcl_Filesystem *
+const Tcl_Filesystem *
Tcl_FSGetFileSystemForPath(
- Tcl_Obj* pathPtr)
+ Tcl_Obj *pathPtr)
{
FilesystemRecord *fsRecPtr;
- Tcl_Filesystem* retVal = NULL;
+ const Tcl_Filesystem *retVal = NULL;
if (pathPtr == NULL) {
Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
@@ -4401,9 +4498,11 @@ Tcl_FSGetFileSystemForPath(
*/
fsRecPtr = FsGetFirstFilesystem();
-
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
return NULL;
+ } else if (retVal != NULL) {
+ /* TODO: Can this happen? */
+ return retVal;
}
/*
@@ -4411,26 +4510,25 @@ Tcl_FSGetFileSystemForPath(
* non-return value of -1 indicates the particular function has succeeded.
*/
- while ((retVal == NULL) && (fsRecPtr != NULL)) {
- Tcl_FSPathInFilesystemProc *proc =
- fsRecPtr->fsPtr->pathInFilesystemProc;
+ for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) {
+ ClientData clientData = NULL;
- if (proc != NULL) {
- ClientData clientData = NULL;
- if ((*proc)(pathPtr, &clientData) != -1) {
- /*
- * We assume the type of pathPtr hasn't been changed by the
- * above call to the pathInFilesystemProc.
- */
+ if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) {
+ continue;
+ }
- TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
- retVal = fsRecPtr->fsPtr;
- }
+ if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
+ /*
+ * We assume the type of pathPtr hasn't been changed by the above
+ * call to the pathInFilesystemProc.
+ */
+
+ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
+ return fsRecPtr->fsPtr;
}
- fsRecPtr = fsRecPtr->nextPtr;
}
- return retVal;
+ return NULL;
}
/*
@@ -4448,7 +4546,7 @@ Tcl_FSGetFileSystemForPath(
* functions not in this file), then one cannot necessarily guarantee
* that the path object pointer is from the correct filesystem.
*
- * Note: in the future it might be desireable to have separate versions
+ * Note: in the future it might be desirable to have separate versions
* of this function with different signatures, for example
* Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
* native paths are all string based, we use just one function.
@@ -4462,11 +4560,11 @@ Tcl_FSGetFileSystemForPath(
*---------------------------------------------------------------------------
*/
-const char *
+const void *
Tcl_FSGetNativePath(
Tcl_Obj *pathPtr)
{
- return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
+ return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}
/*
@@ -4489,7 +4587,7 @@ static void
NativeFreeInternalRep(
ClientData clientData)
{
- ckfree((char *) clientData);
+ ckfree(clientData);
}
/*
@@ -4515,7 +4613,6 @@ Tcl_FSFileSystemInfo(
Tcl_Obj *pathPtr)
{
Tcl_Obj *resPtr;
- Tcl_FSFilesystemPathTypeProc *proc;
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr == NULL) {
@@ -4523,11 +4620,12 @@ Tcl_FSFileSystemInfo(
}
resPtr = Tcl_NewListObj(0, NULL);
- Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1));
+ Tcl_ListObjAppendElement(NULL, resPtr,
+ Tcl_NewStringObj(fsPtr->typeName, -1));
+
+ if (fsPtr->filesystemPathTypeProc != NULL) {
+ Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr);
- proc = fsPtr->filesystemPathTypeProc;
- if (proc != NULL) {
- Tcl_Obj *typePtr = (*proc)(pathPtr);
if (typePtr != NULL) {
Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
}
@@ -4560,23 +4658,23 @@ Tcl_FSPathSeparator(
Tcl_Obj *pathPtr)
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ Tcl_Obj *resultObj;
if (fsPtr == NULL) {
return NULL;
}
+
if (fsPtr->filesystemSeparatorProc != NULL) {
- return (*fsPtr->filesystemSeparatorProc)(pathPtr);
- } else {
- Tcl_Obj *resultObj;
+ return fsPtr->filesystemSeparatorProc(pathPtr);
+ }
- /*
- * Allow filesystems not to provide a filesystemSeparatorProc if they
- * wish to use the standard forward slash.
- */
+ /*
+ * Allow filesystems not to provide a filesystemSeparatorProc if they wish
+ * to use the standard forward slash.
+ */
- TclNewLiteralStringObj(resultObj, "/");
- return resultObj;
- }
+ TclNewLiteralStringObj(resultObj, "/");
+ return resultObj;
}
/*
@@ -4601,6 +4699,7 @@ NativeFilesystemSeparator(
Tcl_Obj *pathPtr)
{
const char *separator = NULL; /* lint */
+
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
@@ -4611,318 +4710,6 @@ NativeFilesystemSeparator(
}
return Tcl_NewStringObj(separator,1);
}
-
-/* Everything from here on is contained in this obsolete ifdef */
-#ifdef USE_OBSOLETE_FS_HOOKS
-
-/*
- *----------------------------------------------------------------------
- *
- * TclStatInsertProc --
- *
- * Insert the passed function pointer at the head of the list of
- * functions which are used during a call to 'TclStat(...)'. The passed
- * function should behave exactly like 'TclStat' when called during that
- * time (see 'TclStat(...)' for more information). The function will be
- * added even if it already in the list.
- *
- * Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
- * not be allocated.
- *
- * Side effects:
- * Memory allocated and modifies the link list for 'TclStat' functions.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclStatInsertProc(
- TclStatProc_ *proc)
-{
- int retVal = TCL_ERROR;
-
- if (proc != NULL) {
- StatProc *newStatProcPtr;
-
- newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));
-
- if (newStatProcPtr != NULL) {
- newStatProcPtr->proc = proc;
- Tcl_MutexLock(&obsoleteFsHookMutex);
- newStatProcPtr->nextPtr = statProcList;
- statProcList = newStatProcPtr;
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- retVal = TCL_OK;
- }
- }
-
- return retVal;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclStatDeleteProc --
- *
- * Removed the passed function pointer from the list of 'TclStat'
- * functions. Ensures that the built-in stat function is not removable.
- *
- * Results:
- * TCL_OK if the function pointer was successfully removed, TCL_ERROR
- * otherwise.
- *
- * Side effects:
- * Memory is deallocated and the respective list updated.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclStatDeleteProc(
- TclStatProc_ *proc)
-{
- int retVal = TCL_ERROR;
- StatProc *tmpStatProcPtr;
- StatProc *prevStatProcPtr = NULL;
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
- tmpStatProcPtr = statProcList;
-
- /*
- * Traverse the 'statProcList' looking for the particular node whose
- * 'proc' member matches 'proc' and remove that one from the list. Ensure
- * that the "default" node cannot be removed.
- */
-
- while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
- if (tmpStatProcPtr->proc == proc) {
- if (prevStatProcPtr == NULL) {
- statProcList = tmpStatProcPtr->nextPtr;
- } else {
- prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
- }
-
- ckfree((char *)tmpStatProcPtr);
-
- retVal = TCL_OK;
- } else {
- prevStatProcPtr = tmpStatProcPtr;
- tmpStatProcPtr = tmpStatProcPtr->nextPtr;
- }
- }
-
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- return retVal;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclAccessInsertProc --
- *
- * Insert the passed function pointer at the head of the list of
- * functions which are used during a call to 'TclAccess(...)'. The passed
- * function should behave exactly like 'TclAccess' when called during
- * that time (see 'TclAccess(...)' for more information). The function
- * will be added even if it already in the list.
- *
- * Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
- * not be allocated.
- *
- * Side effects:
- * Memory allocated and modifies the link list for 'TclAccess' functions.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclAccessInsertProc(
- TclAccessProc_ *proc)
-{
- int retVal = TCL_ERROR;
-
- if (proc != NULL) {
- AccessProc *newAccessProcPtr;
-
- newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));
-
- if (newAccessProcPtr != NULL) {
- newAccessProcPtr->proc = proc;
- Tcl_MutexLock(&obsoleteFsHookMutex);
- newAccessProcPtr->nextPtr = accessProcList;
- accessProcList = newAccessProcPtr;
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- retVal = TCL_OK;
- }
- }
-
- return retVal;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclAccessDeleteProc --
- *
- * Removed the passed function pointer from the list of 'TclAccess'
- * functions. Ensures that the built-in access function is not removable.
- *
- * Results:
- * TCL_OK if the function pointer was successfully removed, TCL_ERROR
- * otherwise.
- *
- * Side effects:
- * Memory is deallocated and the respective list updated.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclAccessDeleteProc(
- TclAccessProc_ *proc)
-{
- int retVal = TCL_ERROR;
- AccessProc *tmpAccessProcPtr;
- AccessProc *prevAccessProcPtr = NULL;
-
- /*
- * Traverse the 'accessProcList' looking for the particular node whose
- * 'proc' member matches 'proc' and remove that one from the list. Ensure
- * that the "default" node cannot be removed.
- */
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
- tmpAccessProcPtr = accessProcList;
- while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
- if (tmpAccessProcPtr->proc == proc) {
- if (prevAccessProcPtr == NULL) {
- accessProcList = tmpAccessProcPtr->nextPtr;
- } else {
- prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
- }
-
- ckfree((char *)tmpAccessProcPtr);
-
- retVal = TCL_OK;
- } else {
- prevAccessProcPtr = tmpAccessProcPtr;
- tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
- }
- }
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- return retVal;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclOpenFileChannelInsertProc --
- *
- * Insert the passed function pointer at the head of the list of
- * functions which are used during a call to 'Tcl_OpenFileChannel(...)'.
- * The passed function should behave exactly like 'Tcl_OpenFileChannel'
- * when called during that time (see 'Tcl_OpenFileChannel(...)' for more
- * information). The function will be added even if it already in the
- * list.
- *
- * Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
- * not be allocated.
- *
- * Side effects:
- * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel'
- * functions.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclOpenFileChannelInsertProc(
- TclOpenFileChannelProc_ *proc)
-{
- int retVal = TCL_ERROR;
-
- if (proc != NULL) {
- OpenFileChannelProc *newOpenFileChannelProcPtr;
-
- newOpenFileChannelProcPtr = (OpenFileChannelProc *)
- ckalloc(sizeof(OpenFileChannelProc));
-
- newOpenFileChannelProcPtr->proc = proc;
- Tcl_MutexLock(&obsoleteFsHookMutex);
- newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
- openFileChannelProcList = newOpenFileChannelProcPtr;
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- retVal = TCL_OK;
- }
-
- return retVal;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclOpenFileChannelDeleteProc --
- *
- * Removed the passed function pointer from the list of
- * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file
- * channel function is not removable.
- *
- * Results:
- * TCL_OK if the function pointer was successfully removed, TCL_ERROR
- * otherwise.
- *
- * Side effects:
- * Memory is deallocated and the respective list updated.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclOpenFileChannelDeleteProc(
- TclOpenFileChannelProc_ *proc)
-{
- int retVal = TCL_ERROR;
- OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
- OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
-
- /*
- * Traverse the 'openFileChannelProcList' looking for the particular node
- * whose 'proc' member matches 'proc' and remove that one from the list.
- */
-
- Tcl_MutexLock(&obsoleteFsHookMutex);
- tmpOpenFileChannelProcPtr = openFileChannelProcList;
- while ((retVal == TCL_ERROR) &&
- (tmpOpenFileChannelProcPtr != NULL)) {
- if (tmpOpenFileChannelProcPtr->proc == proc) {
- if (prevOpenFileChannelProcPtr == NULL) {
- openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
- } else {
- prevOpenFileChannelProcPtr->nextPtr =
- tmpOpenFileChannelProcPtr->nextPtr;
- }
-
- ckfree((char *) tmpOpenFileChannelProcPtr);
-
- retVal = TCL_OK;
- } else {
- prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
- tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
- }
- }
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
-
- return retVal;
-}
-#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Local Variables:
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 595132c..69608cc 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -3,9 +3,11 @@
*
* This file implements objects of type "index". This object type is used
* to lookup a keyword in a table of valid values and cache the index of
- * the matching entry.
+ * the matching entry. Also provides table-based argv/argc processing.
*
+ * Copyright (c) 1990-1994 The Regents of the University of California.
* Copyright (c) 1997 Sun Microsystems, Inc.
+ * Copyright (c) 2006 Sam Bromley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,22 +19,36 @@
* Prototypes for functions defined later in this file:
*/
+static int GetIndexFromObjList(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr,
+ const char *msg, int flags, int *indexPtr);
static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfIndex(Tcl_Obj *objPtr);
static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void FreeIndex(Tcl_Obj *objPtr);
+static int PrefixAllObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int PrefixLongestObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int PrefixMatchObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static void PrintUsage(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable);
/*
* The structure below defines the index Tcl object type by means of functions
* that can be invoked by generic object code.
*/
-static Tcl_ObjType indexType = {
- "index", /* name */
- FreeIndex, /* freeIntRepProc */
- DupIndex, /* dupIntRepProc */
- UpdateStringOfIndex, /* updateStringProc */
- SetIndexFromAny /* setFromAnyProc */
+static const Tcl_ObjType indexType = {
+ "index", /* name */
+ FreeIndex, /* freeIntRepProc */
+ DupIndex, /* dupIntRepProc */
+ UpdateStringOfIndex, /* updateStringProc */
+ SetIndexFromAny /* setFromAnyProc */
};
/*
@@ -44,9 +60,9 @@ static Tcl_ObjType indexType = {
*/
typedef struct {
- void *tablePtr; /* Pointer to the table of strings */
- int offset; /* Offset between table entries */
- int index; /* Selected index into table. */
+ void *tablePtr; /* Pointer to the table of strings */
+ int offset; /* Offset between table entries */
+ int index; /* Selected index into table. */
} IndexRep;
/*
@@ -70,7 +86,7 @@ typedef struct {
*
* Results:
* If the value of objPtr is identical to or a unique abbreviation for
- * one of the entries in objPtr, then the return value is TCL_OK and the
+ * one of the entries in tablePtr, then the return value is TCL_OK and the
* index of the matching entry is stored at *indexPtr. If there isn't a
* proper match, then TCL_ERROR is returned and an error message is left
* in interp's result (unless interp is NULL). The msg argument is used
@@ -87,9 +103,9 @@ typedef struct {
int
Tcl_GetIndexFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
- const char **tablePtr, /* Array of strings to compare against the
+ const char *const*tablePtr, /* Array of strings to compare against the
* value of objPtr; last entry must be NULL
* and there must not be duplicate entries. */
const char *msg, /* Identifying word to use in error
@@ -125,6 +141,90 @@ Tcl_GetIndexFromObj(
/*
*----------------------------------------------------------------------
*
+ * GetIndexFromObjList --
+ *
+ * This procedure looks up an object's value in a table of strings and
+ * returns the index of the matching string, if any.
+ *
+ * Results:
+ * If the value of objPtr is identical to or a unique abbreviation for
+ * one of the entries in tableObjPtr, then the return value is TCL_OK and
+ * the index of the matching entry is stored at *indexPtr. If there isn't
+ * a proper match, then TCL_ERROR is returned and an error message is
+ * left in interp's result (unless interp is NULL). The msg argument is
+ * used in the error message; for example, if msg has the value "option"
+ * then the error message will say something flag 'bad option "foo": must
+ * be ...'
+ *
+ * Side effects:
+ * Removes any internal representation that the object might have. (TODO:
+ * find a way to cache the lookup.)
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+GetIndexFromObjList(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object containing the string to lookup. */
+ Tcl_Obj *tableObjPtr, /* List of strings to compare against the
+ * value of objPtr. */
+ const char *msg, /* Identifying word to use in error
+ * messages. */
+ int flags, /* 0 or TCL_EXACT */
+ int *indexPtr) /* Place to store resulting integer index. */
+{
+
+ int objc, result, t;
+ Tcl_Obj **objv;
+ const char **tablePtr;
+
+ /*
+ * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
+ * of the code there. This is a bit ineffiecient but simpler.
+ */
+
+ result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /*
+ * Build a string table from the list.
+ */
+
+ tablePtr = ckalloc((objc + 1) * sizeof(char *));
+ for (t = 0; t < objc; t++) {
+ if (objv[t] == objPtr) {
+ /*
+ * An exact match is always chosen, so we can stop here.
+ */
+
+ ckfree(tablePtr);
+ *indexPtr = t;
+ return TCL_OK;
+ }
+
+ tablePtr[t] = Tcl_GetString(objv[t]);
+ }
+ tablePtr[objc] = NULL;
+
+ result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
+ sizeof(char *), msg, flags, indexPtr);
+
+ /*
+ * The internal rep must be cleared since tablePtr will go away.
+ */
+
+ TclFreeIntRep(objPtr);
+ ckfree(tablePtr);
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetIndexFromObjStruct --
*
* This function looks up an object's value given a starting string and
@@ -133,13 +233,13 @@ Tcl_GetIndexFromObj(
*
* Results:
* If the value of objPtr is identical to or a unique abbreviation for
- * one of the entries in objPtr, then the return value is TCL_OK and the
- * index of the matching entry is stored at *indexPtr. If there isn't a
- * proper match, then TCL_ERROR is returned and an error message is left
- * in interp's result (unless interp is NULL). The msg argument is used
- * in the error message; for example, if msg has the value "option" then
- * the error message will say something flag 'bad option "foo": must be
- * ...'
+ * one of the entries in tablePtr, then the return value is TCL_OK and
+ * the index of the matching entry is stored at *indexPtr. If there isn't
+ * a proper match, then TCL_ERROR is returned and an error message is
+ * left in interp's result (unless interp is NULL). The msg argument is
+ * used in the error message; for example, if msg has the value "option"
+ * then the error message will say something flag 'bad option "foo": must
+ * be ...'
*
* Side effects:
* The result of the lookup is cached as the internal rep of objPtr, so
@@ -150,7 +250,7 @@ Tcl_GetIndexFromObj(
int
Tcl_GetIndexFromObjStruct(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
@@ -164,7 +264,7 @@ Tcl_GetIndexFromObjStruct(
int *indexPtr) /* Place to store resulting integer index. */
{
int index, idx, numAbbrev;
- char *key, *p1;
+ const char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
@@ -236,12 +336,12 @@ Tcl_GetIndexFromObjStruct(
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.otherValuePtr;
} else {
TclFreeIntRep(objPtr);
- indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
- objPtr->internalRep.otherValuePtr = indexRep;
- objPtr->typePtr = &indexType;
+ indexRep = ckalloc(sizeof(IndexRep));
+ objPtr->internalRep.otherValuePtr = indexRep;
+ objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
@@ -260,17 +360,23 @@ Tcl_GetIndexFromObjStruct(
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
- Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
- !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key,
- "\": must be ", STRING_AT(tablePtr, offset, 0), NULL);
- for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
- *entryPtr != NULL;
- entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
- if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
- Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""),
- " or ", *entryPtr, NULL);
- } else {
- Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
+ Tcl_AppendStringsToObj(resultPtr,
+ (numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
+ msg, " \"", key, NULL);
+ if (STRING_AT(tablePtr, offset, 0) == NULL) {
+ Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
+ } else {
+ Tcl_AppendStringsToObj(resultPtr, "\": must be ",
+ STRING_AT(tablePtr, offset, 0), NULL);
+ for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
+ *entryPtr != NULL;
+ entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
+ if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
+ Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
+ " or ", *entryPtr, NULL);
+ } else {
+ Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
+ }
}
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
@@ -338,7 +444,7 @@ UpdateStringOfIndex(
register const char *indexStr = EXPAND_OF(indexRep);
len = strlen(indexStr);
- buf = (char *) ckalloc(len + 1);
+ buf = ckalloc(len + 1);
memcpy(buf, indexStr, len+1);
objPtr->bytes = buf;
objPtr->length = len;
@@ -368,7 +474,7 @@ DupIndex(
Tcl_Obj *dupPtr)
{
IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr;
- IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+ IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
dupPtr->internalRep.otherValuePtr = dupIndexRep;
@@ -396,13 +502,319 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree((char *) objPtr->internalRep.otherValuePtr);
+ ckfree(objPtr->internalRep.otherValuePtr);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
+ * TclInitPrefixCmd --
+ *
+ * This procedure creates the "prefix" Tcl command. See the user
+ * documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+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},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ Tcl_Command prefixCmd;
+
+ prefixCmd = TclMakeEnsemble(interp, "::tcl::prefix", prefixImplMap);
+ Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
+ "prefix", 0);
+ return prefixCmd;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixMatchObjCmd --
+ *
+ * This function implements the 'prefix match' Tcl command. Refer to the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixMatchObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int flags = 0, result, index;
+ int dummyLength, i, errorLength;
+ Tcl_Obj *errorPtr = NULL;
+ const char *message = "option";
+ Tcl_Obj *tablePtr, *objPtr, *resultPtr;
+ static const char *const matchOptions[] = {
+ "-error", "-exact", "-message", NULL
+ };
+ enum matchOptions {
+ PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE
+ };
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? table string");
+ return TCL_ERROR;
+ }
+
+ for (i = 1; i < (objc - 2); i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum matchOptions) index) {
+ case PRFMATCH_EXACT:
+ flags |= TCL_EXACT;
+ break;
+ case PRFMATCH_MESSAGE:
+ if (i > (objc - 4)) {
+ Tcl_AppendResult(interp, "missing message", NULL);
+ return TCL_ERROR;
+ }
+ i++;
+ message = Tcl_GetString(objv[i]);
+ break;
+ case PRFMATCH_ERROR:
+ if (i > (objc - 4)) {
+ Tcl_AppendResult(interp, "missing error options", NULL);
+ return TCL_ERROR;
+ }
+ i++;
+ result = Tcl_ListObjLength(interp, objv[i], &errorLength);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((errorLength % 2) != 0) {
+ Tcl_AppendResult(interp, "error options must have an even"
+ " number of elements", NULL);
+ return TCL_ERROR;
+ }
+ errorPtr = objv[i];
+ break;
+ }
+ }
+
+ tablePtr = objv[objc - 2];
+ objPtr = objv[objc - 1];
+
+ /*
+ * Check that table is a valid list first, since we want to handle that
+ * error case regardless of level.
+ */
+
+ result = Tcl_ListObjLength(interp, tablePtr, &dummyLength);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
+ &index);
+ if (result != TCL_OK) {
+ if (errorPtr != NULL && errorLength == 0) {
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+ } else if (errorPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_IsShared(errorPtr)) {
+ errorPtr = Tcl_DuplicateObj(errorPtr);
+ }
+ Tcl_ListObjAppendElement(interp, errorPtr,
+ Tcl_NewStringObj("-code", 5));
+ Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
+
+ return Tcl_SetReturnOptions(interp, errorPtr);
+ }
+
+ result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixAllObjCmd --
+ *
+ * This function implements the 'prefix all' Tcl command. Refer to the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixAllObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int tableObjc, result, t, length, elemLength;
+ const char *string, *elemString;
+ Tcl_Obj **tableObjv, *resultPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "table string");
+ return TCL_ERROR;
+ }
+
+ result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ if (result != TCL_OK) {
+ return result;
+ }
+ resultPtr = Tcl_NewListObj(0, NULL);
+ string = Tcl_GetStringFromObj(objv[2], &length);
+
+ for (t = 0; t < tableObjc; t++) {
+ elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+
+ /*
+ * A prefix cannot match if it is longest.
+ */
+
+ if (length <= elemLength) {
+ if (TclpUtfNcmp2(elemString, string, length) == 0) {
+ Tcl_ListObjAppendElement(interp, resultPtr, tableObjv[t]);
+ }
+ }
+ }
+
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixLongestObjCmd --
+ *
+ * This function implements the 'prefix longest' Tcl command. Refer to
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixLongestObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int tableObjc, result, i, t, length, elemLength, resultLength;
+ const char *string, *elemString, *resultString;
+ Tcl_Obj **tableObjv;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "table string");
+ return TCL_ERROR;
+ }
+
+ result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ if (result != TCL_OK) {
+ return result;
+ }
+ string = Tcl_GetStringFromObj(objv[2], &length);
+
+ resultString = NULL;
+ resultLength = 0;
+
+ for (t = 0; t < tableObjc; t++) {
+ elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+
+ /*
+ * First check if the prefix string matches the element. A prefix
+ * cannot match if it is longest.
+ */
+
+ if ((length > elemLength) ||
+ TclpUtfNcmp2(elemString, string, length) != 0) {
+ continue;
+ }
+
+ if (resultString == NULL) {
+ /*
+ * If this is the first match, the longest common substring this
+ * far is the complete string. The result is part of this string
+ * so we only need to adjust the length later.
+ */
+
+ resultString = elemString;
+ resultLength = elemLength;
+ } else {
+ /*
+ * Longest common substring cannot be longer than shortest string.
+ */
+
+ if (elemLength < resultLength) {
+ resultLength = elemLength;
+ }
+
+ /*
+ * Compare strings.
+ */
+
+ for (i = 0; i < resultLength; i++) {
+ if (resultString[i] != elemString[i]) {
+ /*
+ * Adjust in case we stopped in the middle of a UTF char.
+ */
+
+ resultLength = Tcl_UtfPrev(&resultString[i+1],
+ resultString) - resultString;
+ break;
+ }
+ }
+ }
+ }
+ if (resultLength > 0) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(resultString, resultLength));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_WrongNumArgs --
*
* This function generates a "wrong # args" error message in an
@@ -479,6 +891,7 @@ Tcl_WrongNumArgs(
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
+ iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", -1);
} else {
@@ -627,12 +1040,436 @@ Tcl_WrongNumArgs(
Tcl_AppendStringsToObj(objPtr, message, NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseArgsObjv --
+ *
+ * Process an objv array according to a table of expected command-line
+ * options. See the manual page for more details.
+ *
+ * Results:
+ * The return value is a standard Tcl return value. If an error occurs
+ * then an error message is left in the interp's result. Under normal
+ * conditions, both *objcPtr and *objv are modified to return the
+ * arguments that couldn't be processed here (they didn't match the
+ * option table, or followed an TCL_ARGV_REST argument).
+ *
+ * Side effects:
+ * Variables may be modified, or procedures may be called. It all depends
+ * on the arguments and their entries in argTable. See the user
+ * documentation for details.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseArgsObjv(
+ Tcl_Interp *interp, /* Place to store error message. */
+ const Tcl_ArgvInfo *argTable,
+ /* Array of option descriptions. */
+ int *objcPtr, /* Number of arguments in objv. Modified to
+ * hold # args left in objv at end. */
+ Tcl_Obj *const *objv, /* Array of arguments to be parsed. */
+ Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not
+ * processed here. Should be NULL if no return
+ * of arguments is desired. */
+{
+ Tcl_Obj **leftovers; /* Array to write back to remObjv on
+ * successful exit. Will include the name of
+ * the command. */
+ int nrem; /* Size of leftovers.*/
+ register const Tcl_ArgvInfo *infoPtr;
+ /* Pointer to the current entry in the table
+ * of argument descriptions. */
+ const Tcl_ArgvInfo *matchPtr;
+ /* Descriptor that matches current argument. */
+ Tcl_Obj *curArg; /* Current argument */
+ const char *str = NULL;
+ register char c; /* Second character of current arg (used for
+ * quick check for matching; use 2nd char.
+ * because first char. will almost always be
+ * '-'). */
+ int srcIndex; /* Location from which to read next argument
+ * from objv. */
+ int dstIndex; /* Used to keep track of current arguments
+ * being processed, primarily for error
+ * reporting. */
+ int objc; /* # arguments in objv still to process. */
+ int length; /* Number of characters in current argument. */
+
+ if (remObjv != NULL) {
+ /*
+ * Then we should copy the name of the command (0th argument).
+ */
+
+ nrem = 1;
+ leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *));
+ leftovers[nrem-1] = objv[0];
+ leftovers[nrem] = NULL;
+ } else {
+ nrem = 0;
+ leftovers = NULL;
+ }
+
+ /*
+ * OK, now start processing from the second element (1st argument).
+ */
+
+ srcIndex = dstIndex = 1;
+ objc = *objcPtr-1;
+
+ while (objc > 0) {
+ curArg = objv[srcIndex];
+ srcIndex++;
+ objc--;
+ str = Tcl_GetStringFromObj(curArg, &length);
+ if (length > 0) {
+ c = str[1];
+ } else {
+ c = 0;
+ }
+
+ /*
+ * Loop throught the argument descriptors searching for one with the
+ * matching key string. If found, leave a pointer to it in matchPtr.
+ */
+
+ matchPtr = NULL;
+ infoPtr = argTable;
+ for (; (infoPtr != NULL) && (infoPtr->type != TCL_ARGV_END);
+ infoPtr++) {
+ if (infoPtr->keyStr == NULL) {
+ continue;
+ }
+ if ((infoPtr->keyStr[1] != c)
+ || (strncmp(infoPtr->keyStr, str, length) != 0)) {
+ continue;
+ }
+ if (infoPtr->keyStr[length] == 0) {
+ matchPtr = infoPtr;
+ goto gotMatch;
+ }
+ if (matchPtr != NULL) {
+ Tcl_AppendResult(interp, "ambiguous option \"", str, "\"",
+ NULL);
+ goto error;
+ }
+ matchPtr = infoPtr;
+ }
+ if (matchPtr == NULL) {
+ /*
+ * Unrecognized argument. Just copy it down, unless the caller
+ * prefers an error to be registered.
+ */
+
+ if (remObjv == NULL) {
+ Tcl_AppendResult(interp, "unrecognized argument \"", str,
+ "\"", NULL);
+ goto error;
+ }
+
+ dstIndex++; /* This argument is now handled */
+ nrem++;
+
+ /*
+ * Allocate nrem (+1 extra for NULL terminator) pointers.
+ */
+
+ leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *));
+ leftovers[nrem-1] = curArg;
+ continue;
+ }
+
+ /*
+ * Take the appropriate action based on the option type
+ */
+
+ gotMatch:
+ infoPtr = matchPtr;
+ switch (infoPtr->type) {
+ case TCL_ARGV_CONSTANT:
+ *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr);
+ break;
+ case TCL_ARGV_INT:
+ if (objc == 0) {
+ goto missingArg;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[srcIndex],
+ (int *) infoPtr->dstPtr) == TCL_ERROR) {
+ Tcl_AppendResult(interp, "expected integer argument for \"",
+ infoPtr->keyStr, "\" but got \"",
+ Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ goto error;
+ }
+ srcIndex++;
+ objc--;
+ break;
+ case TCL_ARGV_STRING:
+ if (objc == 0) {
+ goto missingArg;
+ }
+ *((const char **) infoPtr->dstPtr) =
+ Tcl_GetString(objv[srcIndex]);
+ srcIndex++;
+ objc--;
+ break;
+ case TCL_ARGV_REST:
+ *((int *) infoPtr->dstPtr) = dstIndex;
+ goto argsDone;
+ case TCL_ARGV_FLOAT:
+ if (objc == 0) {
+ goto missingArg;
+ }
+ if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
+ (double *) infoPtr->dstPtr) == TCL_ERROR) {
+ Tcl_AppendResult(interp, "expected floating-point argument ",
+ "for \"", infoPtr->keyStr, "\" but got \"",
+ Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ goto error;
+ }
+ srcIndex++;
+ objc--;
+ break;
+ case TCL_ARGV_FUNC: {
+ Tcl_ArgvFuncProc *handlerProc;
+ Tcl_Obj *argObj;
+
+ if (objc == 0) {
+ argObj = NULL;
+ } else {
+ argObj = objv[srcIndex];
+ }
+ handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr;
+ if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
+ srcIndex++;
+ objc--;
+ }
+ break;
+ }
+ case TCL_ARGV_GENFUNC: {
+ Tcl_ArgvGenFuncProc *handlerProc;
+
+ handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr;
+ objc = handlerProc(infoPtr->clientData, interp, objc,
+ &objv[srcIndex], infoPtr->dstPtr);
+ if (objc < 0) {
+ goto error;
+ }
+ break;
+ }
+ case TCL_ARGV_HELP:
+ PrintUsage(interp, argTable);
+ goto error;
+ default: {
+ char buf[64 + TCL_INTEGER_SPACE];
+
+ sprintf(buf, "bad argument type %d in Tcl_ArgvInfo",
+ infoPtr->type);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+ goto error;
+ }
+ }
+ }
+
+ /*
+ * If we broke out of the loop because of an OPT_REST argument, copy the
+ * remaining arguments down.
+ */
+
+ argsDone:
+ if (remObjv == NULL) {
+ /*
+ * Nothing to do.
+ */
+
+ return TCL_OK;
+ }
+
+ if (objc > 0) {
+ leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *));
+ while (objc) {
+ leftovers[nrem] = objv[srcIndex];
+ nrem++;
+ srcIndex++;
+ objc--;
+ }
+ } else if (leftovers != NULL) {
+ ckfree(leftovers);
+ }
+ leftovers[nrem] = NULL;
+ *objcPtr = nrem;
+ *remObjv = leftovers;
+ return TCL_OK;
+
+ /*
+ * Make sure to handle freeing any temporary space we've allocated on the
+ * way to an error.
+ */
+
+ missingArg:
+ Tcl_AppendResult(interp, "\"", str,
+ "\" option requires an additional argument", NULL);
+ error:
+ if (leftovers != NULL) {
+ ckfree(leftovers);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PrintUsage --
+ *
+ * Generate a help string describing command-line options.
+ *
+ * Results:
+ * The interp's result will be modified to hold a help string describing
+ * all the options in argTable.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintUsage(
+ Tcl_Interp *interp, /* Place information in this interp's result
+ * area. */
+ const Tcl_ArgvInfo *argTable)
+ /* Array of command-specific argument
+ * descriptions. */
+{
+ register const Tcl_ArgvInfo *infoPtr;
+ int width, numSpaces;
+#define NUM_SPACES 20
+ static char spaces[] = " ";
+ char tmp[TCL_DOUBLE_SPACE];
+
+ /*
+ * First, compute the width of the widest option key, so that we can make
+ * everything line up.
+ */
+
+ width = 4;
+ for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
+ int length;
+
+ if (infoPtr->keyStr == NULL) {
+ continue;
+ }
+ length = strlen(infoPtr->keyStr);
+ if (length > width) {
+ width = length;
+ }
+ }
+
+ /*
+ * Now add the option information, with pretty-printing.
+ */
+
+ Tcl_AppendResult(interp, "Command-specific options:", NULL);
+ for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
+ if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
+ Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL);
+ continue;
+ }
+ Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL);
+ numSpaces = width + 1 - strlen(infoPtr->keyStr);
+ while (numSpaces > 0) {
+ if (numSpaces >= NUM_SPACES) {
+ Tcl_AppendResult(interp, spaces, NULL);
+ } else {
+ Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL);
+ }
+ numSpaces -= NUM_SPACES;
+ }
+ Tcl_AppendResult(interp, infoPtr->helpStr, NULL);
+ switch (infoPtr->type) {
+ case TCL_ARGV_INT:
+ sprintf(tmp, "%d", *((int *) infoPtr->dstPtr));
+ Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
+ break;
+ case TCL_ARGV_FLOAT:
+ sprintf(tmp, "%g", *((double *) infoPtr->dstPtr));
+ Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
+ break;
+ case TCL_ARGV_STRING: {
+ char *string;
+
+ string = *((char **) infoPtr->dstPtr);
+ if (string != NULL) {
+ Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string,
+ "\"", NULL);
+ }
+ break;
+ }
+ default:
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCompletionCodeFromObj --
+ *
+ * Parses Completion code Code
+ *
+ * Results:
+ * Returns TCL_ERROR if the value is an invalid completion code.
+ * Otherwise, returns TCL_OK, and writes the completion code to
+ * the pointer provided.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetCompletionCodeFromObj(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *value,
+ int *code) /* Argument objects. */
+{
+ static const char *const returnCodes[] = {
+ "ok", "error", "return", "break", "continue", NULL
+ };
+
+ if ((value->typePtr != &indexType)
+ && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
+ return TCL_OK;
+ }
+ if (TCL_OK == Tcl_GetIndexFromObj(
+ NULL, value, returnCodes, NULL, TCL_EXACT, code)) {
+ return TCL_OK;
+ }
+ /*
+ * Value is not a legal completion code.
+ */
+
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad completion code \"",
+ TclGetString(value),
+ "\": must be ok, error, return, break, "
+ "continue, or an integer", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index e30379e..df60dae 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -18,6 +18,7 @@ library tcl
# Define the unsupported generic interfaces.
interface tclInt
+scspec EXTERN
# Declare each of the functions in the unsupported internal Tcl
# interface. These interfaces are allowed to changed between versions.
@@ -25,727 +26,733 @@ interface tclInt
# be changed between versions to avoid gratuitous incompatibilities.
# Replaced by Tcl_FSAccess in 8.4:
-#declare 0 generic {
-# int TclAccess(CONST char *path, int mode)
+#declare 0 {
+# int TclAccess(const char *path, int mode)
#}
-#declare 1 generic {
+#declare 1 {
# int TclAccessDeleteProc(TclAccessProc_ *proc)
#}
-#declare 2 generic {
+#declare 2 {
# int TclAccessInsertProc(TclAccessProc_ *proc)
#}
-declare 3 generic {
+declare 3 {
void TclAllocateFreeObjects(void)
}
# Replaced by TclpChdir in 8.1:
-# declare 4 generic {
+# declare 4 {
# int TclChdir(Tcl_Interp *interp, char *dirName)
# }
-declare 5 generic {
+declare 5 {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
-declare 6 generic {
+declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
-declare 7 generic {
- int TclCopyAndCollapse(int count, CONST char *src, char *dst)
+declare 7 {
+ int TclCopyAndCollapse(int count, const char *src, char *dst)
}
-declare 8 generic {
- int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
+declare 8 {
+ int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
-declare 9 generic {
- int TclCreatePipeline(Tcl_Interp *interp, int argc, CONST char **argv,
+declare 9 {
+ int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
-declare 10 generic {
+declare 10 {
int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
- CONST char *procName,
+ const char *procName,
Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr)
}
-declare 11 generic {
+declare 11 {
void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr)
}
-declare 12 generic {
+declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
# Removed in 8.5
-#declare 13 generic {
+#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
-declare 14 generic {
+declare 14 {
int TclDumpMemoryInfo(ClientData clientData, int flags)
}
# Removed in 8.1:
-# declare 15 generic {
+# declare 15 {
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
-declare 16 generic {
+declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
# Removed in 8.4
-#declare 17 generic {
-# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+#declare 17 {
+# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
#}
-#declare 18 generic {
+#declare 18 {
# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
#}
-#declare 19 generic {
+#declare 19 {
# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
#}
-#declare 20 generic {
+#declare 20 {
# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
#}
-#declare 21 generic {
+#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
-declare 22 generic {
- int TclFindElement(Tcl_Interp *interp, CONST char *listStr,
- int listLength, CONST char **elementPtr, CONST char **nextPtr,
+declare 22 {
+ int TclFindElement(Tcl_Interp *interp, const char *listStr,
+ int listLength, const char **elementPtr, const char **nextPtr,
int *sizePtr, int *bracePtr)
}
-declare 23 generic {
- Proc *TclFindProc(Interp *iPtr, CONST char *procName)
+declare 23 {
+ Proc *TclFindProc(Interp *iPtr, const char *procName)
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
-declare 24 generic {
+declare 24 {
int TclFormatInt(char *buffer, long n)
}
-declare 25 generic {
+declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
-# declare 26 generic {
+# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
# }
# Removed in 8.5
-#declare 27 generic {
+#declare 27 {
# int TclGetDate(char *p, unsigned long now, long zone,
# unsigned long *timePtr)
#}
-declare 28 generic {
+declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
# Removed in 8.4b2:
-#declare 29 generic {
+#declare 29 {
# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, int flags)
#}
-# Replaced by char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
-# declare 30 generic {
-# char *TclGetEnv(CONST char *name)
+# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1:
+# declare 30 {
+# char *TclGetEnv(const char *name)
# }
-declare 31 generic {
- CONST char *TclGetExtension(CONST char *name)
+declare 31 {
+ const char *TclGetExtension(const char *name)
}
-declare 32 generic {
- int TclGetFrame(Tcl_Interp *interp, CONST char *str,
+declare 32 {
+ int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
# Removed in Tcl 8.5
-#declare 33 generic {
+#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
-declare 34 generic {
+declare 34 {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
# Removed in 8.4b2:
-#declare 35 generic {
+#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
-declare 36 generic {
- int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
-}
-declare 37 generic {
- int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
+# Removed in 8.6a2
+#declare 36 {
+# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
+#}
+declare 37 {
+ int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
}
-declare 38 generic {
- int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName,
+declare 38 {
+ int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
- CONST char **simpleNamePtr)
+ const char **simpleNamePtr)
}
-declare 39 generic {
+declare 39 {
TclObjCmdProcType TclGetObjInterpProc(void)
}
-declare 40 generic {
- int TclGetOpenMode(Tcl_Interp *interp, CONST char *str, int *seekFlagPtr)
+declare 40 {
+ int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
-declare 41 generic {
+declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
-declare 42 generic {
- char *TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
+declare 42 {
+ CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
# Removed in Tcl 8.5a2
-#declare 43 generic {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+#declare 43 {
+# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
-declare 44 generic {
- int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr)
+declare 44 {
+ int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
-declare 45 generic {
+declare 45 {
int TclHideUnsafeCommands(Tcl_Interp *interp)
}
-declare 46 generic {
+declare 46 {
int TclInExit(void)
}
# Removed in 8.4b2:
-#declare 47 generic {
+#declare 47 {
# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
#}
# Removed in 8.4b2:
-#declare 48 generic {
+#declare 48 {
# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
# long incrAmount)
#}
-#declare 49 generic {
+#declare 49 {
# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
#}
-declare 50 generic {
+declare 50 {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
}
-declare 51 generic {
+declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
# Removed in Tcl 8.5a2
-#declare 52 generic {
-# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+#declare 52 {
+# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
-declare 53 generic {
+declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
int argc, CONST84 char **argv)
}
-declare 54 generic {
+declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
+ int objc, Tcl_Obj *const objv[])
}
-declare 55 generic {
+declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
-# declare 56 generic {
+# declare 56 {
# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr)
# }
# Signature changed to take a length in 8.1:
-# declare 57 generic {
+# declare 57 {
# int TclLooksLikeInt(char *p)
# }
-declare 58 generic {
- Var *TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
- int flags, CONST char *msg, int createPart1, int createPart2,
+declare 58 {
+ Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2,
+ int flags, const char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
# Replaced by Tcl_FSMatchInDirectory in 8.4
-#declare 59 generic {
+#declare 59 {
# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail)
#}
-declare 60 generic {
- int TclNeedSpace(CONST char *start, CONST char *end)
+declare 60 {
+ int TclNeedSpace(const char *start, const char *end)
}
-declare 61 generic {
+declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
-declare 62 generic {
+declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
-declare 63 generic {
+declare 63 {
int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
+ int objc, Tcl_Obj *const objv[])
}
-declare 64 generic {
- int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
+declare 64 {
+ int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
# Removed in Tcl 8.5a2
-#declare 65 generic {
+#declare 65 {
# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
-# Tcl_Obj *CONST objv[], int flags)
+# Tcl_Obj *const objv[], int flags)
#}
-#declare 66 generic {
+#declare 66 {
# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc)
#}
-#declare 67 generic {
+#declare 67 {
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
-#declare 68 generic {
-# int TclpAccess(CONST char *path, int mode)
+#declare 68 {
+# int TclpAccess(const char *path, int mode)
#}
-declare 69 generic {
+declare 69 {
char *TclpAlloc(unsigned int size)
}
-#declare 70 generic {
-# int TclpCopyFile(CONST char *source, CONST char *dest)
+#declare 70 {
+# int TclpCopyFile(const char *source, const char *dest)
#}
-#declare 71 generic {
-# int TclpCopyDirectory(CONST char *source, CONST char *dest,
+#declare 71 {
+# int TclpCopyDirectory(const char *source, const char *dest,
# Tcl_DString *errorPtr)
#}
-#declare 72 generic {
-# int TclpCreateDirectory(CONST char *path)
+#declare 72 {
+# int TclpCreateDirectory(const char *path)
#}
-#declare 73 generic {
-# int TclpDeleteFile(CONST char *path)
+#declare 73 {
+# int TclpDeleteFile(const char *path)
#}
-declare 74 generic {
+declare 74 {
void TclpFree(char *ptr)
}
-declare 75 generic {
+declare 75 {
unsigned long TclpGetClicks(void)
}
-declare 76 generic {
+declare 76 {
unsigned long TclpGetSeconds(void)
}
# deprecated
-declare 77 generic {
+declare 77 {
void TclpGetTime(Tcl_Time *time)
}
-declare 78 generic {
+declare 78 {
int TclpGetTimeZone(unsigned long time)
}
# Replaced by Tcl_FSListVolumes in 8.4:
-#declare 79 generic {
+#declare 79 {
# int TclpListVolumes(Tcl_Interp *interp)
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
-#declare 80 generic {
+#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
-declare 81 generic {
+declare 81 {
char *TclpRealloc(char *ptr, unsigned int size)
}
-#declare 82 generic {
-# int TclpRemoveDirectory(CONST char *path, int recursive,
+#declare 82 {
+# int TclpRemoveDirectory(const char *path, int recursive,
# Tcl_DString *errorPtr)
#}
-#declare 83 generic {
-# int TclpRenameFile(CONST char *source, CONST char *dest)
+#declare 83 {
+# int TclpRenameFile(const char *source, const char *dest)
#}
# Removed in 8.1:
-# declare 84 generic {
+# declare 84 {
# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
# ParseValue *pvPtr)
# }
-# declare 85 generic {
+# declare 85 {
# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
# char **termPtr, ParseValue *pvPtr)
# }
-# declare 86 generic {
+# declare 86 {
# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
# int flags, char **termPtr, ParseValue *pvPtr)
# }
-# declare 87 generic {
+# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
-declare 88 generic {
+declare 88 {
char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
- CONST char *name1, CONST char *name2, int flags)
+ const char *name1, const char *name2, int flags)
}
-declare 89 generic {
+declare 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
-# declare 90 generic {
+# declare 90 {
# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
# }
-declare 91 generic {
+declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
-declare 92 generic {
+declare 92 {
int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
- Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description,
- CONST char *procName)
+ Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description,
+ const char *procName)
}
-declare 93 generic {
+declare 93 {
void TclProcDeleteProc(ClientData clientData)
}
# Removed in Tcl 8.5:
-#declare 94 generic {
+#declare 94 {
# int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
-# int argc, CONST84 char **argv)
+# int argc, const char **argv)
#}
# Replaced by Tcl_FSStat in 8.4:
-#declare 95 generic {
-# int TclpStat(CONST char *path, Tcl_StatBuf *buf)
+#declare 95 {
+# int TclpStat(const char *path, Tcl_StatBuf *buf)
#}
-declare 96 generic {
- int TclRenameCommand(Tcl_Interp *interp, CONST char *oldName,
- CONST char *newName)
+declare 96 {
+ int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
+ const char *newName)
}
-declare 97 generic {
+declare 97 {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
-declare 98 generic {
+declare 98 {
int TclServiceIdle(void)
}
# Removed in 8.4b2:
-#declare 99 generic {
+#declare 99 {
# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
#}
# Removed in 8.4b2:
-#declare 100 generic {
+#declare 100 {
# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *objPtr, int flags)
#}
-declare 101 generic {
- char *TclSetPreInitScript(char *string)
+declare 101 {
+ CONST86 char *TclSetPreInitScript(const char *string)
}
-declare 102 generic {
+declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
}
-declare 103 generic {
- int TclSockGetPort(Tcl_Interp *interp, CONST char *str, CONST char *proto,
+declare 103 {
+ int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 generic {
- int TclSockMinimumBuffers(int sock, int size)
+declare 104 {
+ int TclSockMinimumBuffers(ClientData sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
-#declare 105 generic {
-# int TclStat(CONST char *path, Tcl_StatBuf *buf)
+#declare 105 {
+# int TclStat(const char *path, Tcl_StatBuf *buf)
#}
-#declare 106 generic {
+#declare 106 {
# int TclStatDeleteProc(TclStatProc_ *proc)
#}
-#declare 107 generic {
+#declare 107 {
# int TclStatInsertProc(TclStatProc_ *proc)
#}
-declare 108 generic {
+declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
-declare 109 generic {
+declare 109 {
int TclUpdateReturnInfo(Interp *iPtr)
}
# Removed in 8.1:
-# declare 110 generic {
+# declare 110 {
# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
# }
# Procedures used in conjunction with Tcl namespaces. They are
# defined here instead of in tcl.decls since they are not stable yet.
-declare 111 generic {
- void Tcl_AddInterpResolvers(Tcl_Interp *interp, CONST char *name,
+declare 111 {
+ void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 112 generic {
+declare 112 {
int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
-declare 113 generic {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name,
+declare 113 {
+ Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
-declare 114 generic {
+declare 114 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
-declare 115 generic {
+declare 115 {
int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int resetListFirst)
+ const char *pattern, int resetListFirst)
}
-declare 116 generic {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name,
+declare 116 {
+ Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 117 generic {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name,
+declare 117 {
+ Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 118 generic {
- int Tcl_GetInterpResolvers(Tcl_Interp *interp, CONST char *name,
+declare 118 {
+ int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
}
-declare 119 generic {
+declare 119 {
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
-declare 120 generic {
- Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, CONST char *name,
+declare 120 {
+ Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 121 generic {
+declare 121 {
int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern)
+ const char *pattern)
}
-declare 122 generic {
+declare 122 {
Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 123 generic {
+declare 123 {
void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
-declare 124 generic {
+declare 124 {
Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
}
-declare 125 generic {
+declare 125 {
Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
}
-declare 126 generic {
+declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
-declare 127 generic {
+declare 127 {
int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int allowOverwrite)
+ const char *pattern, int allowOverwrite)
}
-declare 128 generic {
+declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
-declare 129 generic {
+declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
-declare 130 generic {
- int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, CONST char *name)
+declare 130 {
+ int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
-declare 131 generic {
+declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 132 generic {
+declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 generic {
- struct tm *TclpGetDate(CONST time_t *time, int useGMT)
+declare 133 {
+ struct tm *TclpGetDate(const time_t *time, int useGMT)
}
# Removed in 8.5
-#declare 134 generic {
-# size_t TclpStrftime(char *s, size_t maxsize, CONST char *format,
-# CONST struct tm *t, int useGMT)
+#declare 134 {
+# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
+# const struct tm *t, int useGMT)
#}
-#declare 135 generic {
+#declare 135 {
# int TclpCheckStackSpace(void)
#}
# Added in 8.1:
-#declare 137 generic {
-# int TclpChdir(CONST char *dirName)
+#declare 137 {
+# int TclpChdir(const char *dirName)
#}
-declare 138 generic {
- CONST84_RETURN char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
+declare 138 {
+ CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
-#declare 139 generic {
+#declare 139 {
# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
-#declare 140 generic {
-# int TclLooksLikeInt(CONST char *bytes, int length)
+#declare 140 {
+# int TclLooksLikeInt(const char *bytes, int length)
#}
# This is used by TclX, but should otherwise be considered private
-declare 141 generic {
+declare 141 {
CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
-declare 142 generic {
+declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, ClientData clientData)
}
-declare 143 generic {
+declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
-declare 144 generic {
+declare 144 {
void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
int index)
}
-declare 145 generic {
- struct AuxDataType *TclGetAuxDataType(char *typeName)
+declare 145 {
+ const struct AuxDataType *TclGetAuxDataType(const char *typeName)
}
-declare 146 generic {
+declare 146 {
TclHandle TclHandleCreate(void *ptr)
}
-declare 147 generic {
+declare 147 {
void TclHandleFree(TclHandle handle)
}
-declare 148 generic {
+declare 148 {
TclHandle TclHandlePreserve(TclHandle handle)
}
-declare 149 generic {
+declare 149 {
void TclHandleRelease(TclHandle handle)
}
# Added for Tcl 8.2
-declare 150 generic {
+declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
-declare 151 generic {
+declare 151 {
void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr,
int *endPtr)
}
-declare 152 generic {
+declare 152 {
void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
-declare 153 generic {
+declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
# moved to tclTest.c (static) in 8.3.2/8.4a2
-#declare 154 generic {
+#declare 154 {
# int TclTestChannelCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
-#declare 155 generic {
+#declare 155 {
# int TclTestChannelEventCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
-declare 156 generic {
- void TclRegError(Tcl_Interp *interp, CONST char *msg,
+declare 156 {
+ void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
-declare 157 generic {
- Var *TclVarTraceExists(Tcl_Interp *interp, CONST char *varName)
-}
-declare 158 generic {
- void TclSetStartupScriptFileName(CONST char *filename)
-}
-declare 159 generic {
- CONST84_RETURN char *TclGetStartupScriptFileName(void)
+declare 157 {
+ Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-#declare 160 generic {
+# REMOVED - use public Tcl_SetStartupScript()
+#declare 158 {
+# void TclSetStartupScriptFileName(const char *filename)
+#}
+# REMOVED - 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,
# GlobTypeData *types)
#}
# new in 8.3.2/8.4a2
-declare 161 generic {
+declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
-declare 162 generic {
+declare 162 {
void TclChannelEventScriptInvoker(ClientData clientData, int flags)
}
# ALERT: The result of 'TclGetInstructionTable' is actually a
-# "InstructionDesc*" but we do not want to describe this structure in
+# "const InstructionDesc*" but we do not want to describe this structure in
# "tclInt.h". It is described in "tclCompile.h". Use a cast to the
# correct type when calling this procedure.
-declare 163 generic {
- void *TclGetInstructionTable(void)
+declare 163 {
+ const void *TclGetInstructionTable(void)
}
# ALERT: The argument of 'TclExpandCodeArray' is actually a
# "CompileEnv*" but we do not want to describe this structure in
# "tclInt.h". It is described in "tclCompile.h".
-declare 164 generic {
+declare 164 {
void TclExpandCodeArray(void *envPtr)
}
# These functions are vfs aware, but are generally only useful internally.
-declare 165 generic {
+declare 165 {
void TclpSetInitialEncodings(void)
}
# New function due to TIP #33
-declare 166 generic {
+declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-declare 167 generic {
- void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
-}
-declare 168 generic {
- Tcl_Obj *TclGetStartupScriptPath(void)
-}
+# REMOVED - use public Tcl_SetStartupScript()
+#declare 167 {
+# void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+#}
+# REMOVED - use public Tcl_GetStartupScript()
+#declare 168 {
+# Tcl_Obj *TclGetStartupScriptPath(void)
+#}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
-declare 169 generic {
- int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n)
+declare 169 {
+ int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
}
-declare 170 generic {
- int TclCheckInterpTraces(Tcl_Interp *interp, CONST char *command,
+declare 170 {
+ int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *CONST objv[])
+ int objc, Tcl_Obj *const objv[])
}
-declare 171 generic {
- int TclCheckExecutionTraces(Tcl_Interp *interp, CONST char *command,
+declare 171 {
+ int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *CONST objv[])
+ int objc, Tcl_Obj *const objv[])
}
-declare 172 generic {
+declare 172 {
int TclInThreadExit(void)
}
# added for 8.4.2
-declare 173 generic {
- int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen,
- CONST Tcl_UniChar *pattern, int ptnLen, int flags)
+declare 173 {
+ int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
+ const Tcl_UniChar *pattern, int ptnLen, int flags)
}
# added for 8.4.3
-#declare 174 generic {
+#declare 174 {
# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
#}
# Factoring out of trace code
-declare 175 generic {
+declare 175 {
int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
- CONST char *part1, CONST char *part2, int flags, int leaveErrMsg)
+ const char *part1, const char *part2, int flags, int leaveErrMsg)
}
-declare 176 generic {
+declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
-declare 177 generic {
- void TclVarErrMsg(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
- CONST char *operation, CONST char *reason)
-}
-declare 178 generic {
- void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName)
-}
-declare 179 generic {
- Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr)
+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)
+#}
# REMOVED
# Allocate lists without copying arrays
-# declare 180 generic {
+# declare 180 {
# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
# }
-#declare 181 generic {
+#declare 181 {
# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
-# CONST char *file, int line)
+# const char *file, int line)
#}
-# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
+# TclpGmtime and TclpLocaltime promoted to the interface from unix
-declare 182 generic {
- struct tm *TclpLocaltime(CONST time_t *clock)
+declare 182 {
+ struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 generic {
- struct tm *TclpGmtime(CONST time_t *clock)
+declare 183 {
+ struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
@@ -753,43 +760,43 @@ declare 183 generic {
### REMOVED on grounds it should never have been exposed. All these
### functions are now either static in tclThreadStorage.c or
### MODULE_SCOPE.
-# declare 184 generic {
+# declare 184 {
# void TclThreadStorageLockInit(void)
# }
-# declare 185 generic {
+# declare 185 {
# void TclThreadStorageLock(void)
# }
-# declare 186 generic {
+# declare 186 {
# void TclThreadStorageUnlock(void)
# }
-# declare 187 generic {
+# declare 187 {
# void TclThreadStoragePrint(FILE *outFile, int flags)
# }
-# declare 188 generic {
+# declare 188 {
# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)
# }
-# declare 189 generic {
+# declare 189 {
# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)
# }
-# declare 190 generic {
+# declare 190 {
# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)
# }
-# declare 191 generic {
+# declare 191 {
# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)
# }
-# declare 192 generic {
+# declare 192 {
# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)
# }
-# declare 193 generic {
+# declare 193 {
# void TclFinalizeThreadStorageThread(Tcl_ThreadId id)
# }
-# declare 194 generic {
+# declare 194 {
# void TclFinalizeThreadStorage(void)
# }
-# declare 195 generic {
+# declare 195 {
# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)
# }
-# declare 196 generic {
+# declare 196 {
# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)
# }
@@ -797,152 +804,206 @@ declare 183 generic {
# Added in tcl8.5a5 for compiler/executor experimentation.
# Disabled in Tcl 8.5.1; experiments terminated. :/
#
-#declare 197 generic {
+#declare 197 {
# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
-# CONST CmdFrame *invoker, int word)
+# const CmdFrame *invoker, int word)
#}
-declare 198 generic {
+declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
-#declare 199 generic {
-# int TclMatchIsTrivial(CONST char *pattern)
+#declare 199 {
+# int TclMatchIsTrivial(const char *pattern)
#}
# 200-208 exported for use by the test suite [Bug 1054748]
-declare 200 generic {
+declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
Tcl_Obj **errorPtr)
}
-declare 201 generic {
+declare 201 {
int TclpObjCopyDirectory(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
Tcl_Obj **errorPtr)
}
-declare 202 generic {
+declare 202 {
int TclpObjCreateDirectory(Tcl_Obj *pathPtr)
}
-declare 203 generic {
+declare 203 {
int TclpObjDeleteFile(Tcl_Obj *pathPtr)
}
-declare 204 generic {
+declare 204 {
int TclpObjCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
-declare 205 generic {
+declare 205 {
int TclpObjRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
-declare 206 generic {
+declare 206 {
int TclpObjStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
-declare 207 generic {
+declare 207 {
int TclpObjAccess(Tcl_Obj *pathPtr, int mode)
}
-declare 208 generic {
+declare 208 {
Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp,
Tcl_Obj *pathPtr, int mode, int permissions)
}
# Made public by TIP 258
-#declare 209 generic {
+#declare 209 {
# Tcl_Obj *TclGetEncodingSearchPath(void)
#}
-#declare 210 generic {
+#declare 210 {
# int TclSetEncodingSearchPath(Tcl_Obj *searchPath)
#}
-#declare 211 generic {
-# CONST char *TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
+#declare 211 {
+# const char *TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
#}
-declare 212 generic {
- void TclpFindExecutable(CONST char *argv0)
+declare 212 {
+ void TclpFindExecutable(const char *argv0)
}
-declare 213 generic {
+declare 213 {
Tcl_Obj *TclGetObjNameOfExecutable(void)
}
-declare 214 generic {
+declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
-declare 215 generic {
+declare 215 {
void *TclStackAlloc(Tcl_Interp *interp, int numBytes)
}
-declare 216 generic {
+declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
}
-declare 217 generic {
+declare 217 {
int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
Tcl_Namespace *namespacePtr, int isProcCallFrame)
}
-declare 218 generic {
+declare 218 {
void TclPopStackFrame(Tcl_Interp *interp)
}
# for use in tclTest.c
-declare 224 generic {
+declare 224 {
TclPlatformType *TclGetPlatform(void)
}
#
-declare 225 generic {
+declare 225 {
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
- int keyc, Tcl_Obj *CONST keyv[], int flags)
+ int keyc, Tcl_Obj *const keyv[], int flags)
}
-declare 226 generic {
+declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
-declare 227 generic {
+declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
-declare 228 generic {
- int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
- int skip, ProcErrorProc errorProc)
-}
-declare 229 generic {
+# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
+# core and NRE-enabled
+# declare 228 {
+# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
+# int skip, ProcErrorProc *errorProc)
+# }
+declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
- CONST char *myName, int myFlags, int index)
+ const char *myName, int myFlags, int index)
}
-declare 230 generic {
+declare 230 {
Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
- CONST char *part2, int flags, CONST char *msg,
- CONST int createPart1, CONST int createPart2, Var **arrayPtrPtr)
+ const char *part2, int flags, const char *msg,
+ const int createPart1, const int createPart2, Var **arrayPtrPtr)
}
-declare 231 generic {
+declare 231 {
int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Namespace **nsPtrPtr)
}
# Bits and pieces of TIP#280's guts
-declare 232 generic {
+declare 232 {
int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
- CONST CmdFrame *invoker, int word)
+ const CmdFrame *invoker, int word)
}
-declare 233 generic {
+declare 233 {
void TclGetSrcInfoForPc(CmdFrame *contextPtr)
}
# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
-declare 234 generic {
- Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, CONST char *key,
+declare 234 {
+ Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
-declare 235 generic {
+declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# TIP 337 made this one public
-declare 236 generic {
- void TclBackgroundException(Tcl_Interp *interp, int code)
+#declare 236 {
+# void TclBackgroundException(Tcl_Interp *interp, int code)
+#}
+
+# TIP #285: Script cancellation support.
+declare 237 {
+ int TclResetCancellation(Tcl_Interp *interp, int force)
+}
+
+# NRE functions for "rogue" extensions to exploit NRE; they will need to
+# include NRE.h too.
+declare 238 {
+ int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+}
+declare 239 {
+ int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
+ int skip, ProcErrorProc *errorProc)
+}
+declare 240 {
+ int TclNRRunCallbacks(Tcl_Interp *interp, int result,
+ struct NRE_callback *rootPtr)
+}
+declare 241 {
+ int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
+ const CmdFrame *invoker, int word)
+}
+declare 242 {
+ int TclNREvalObjv(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags, Command *cmdPtr)
}
# Tcl_Obj leak detection support.
-declare 243 generic {
+declare 243 {
void TclDbDumpActiveObjects(FILE *outFile)
}
+# Functions to make things better for itcl
+declare 244 {
+ Tcl_HashTable *TclGetNamespaceChildTable(Tcl_Namespace *nsPtr)
+}
+declare 245 {
+ Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr)
+}
+declare 246 {
+ int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
+ int numInserted, Tcl_Obj *const *objv)
+}
+declare 247 {
+ void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble)
+}
+
+declare 248 {
+ int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
+ Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr)
+}
+
declare 249 {
char* TclDoubleDigits(double dv, int ndigits, int flags,
int* decpt, int* signum, char** endPtr)
}
-
+
+# TIP #285: Script cancellation support.
+declare 250 {
+ void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
+}
##############################################################################
@@ -961,11 +1022,11 @@ declare 1 win {
void TclWinConvertWSAError(unsigned long errCode)
}
declare 2 win {
- struct servent *TclWinGetServByName(CONST char *nm,
- CONST char *proto)
+ struct servent *TclWinGetServByName(const char *nm,
+ const char *proto)
}
declare 3 win {
- int TclWinGetSockOpt(int s, int level, int optname,
+ int TclWinGetSockOpt(SOCKET s, int level, int optname,
char FAR *optval, int FAR *optlen)
}
declare 4 win {
@@ -979,8 +1040,8 @@ declare 6 win {
u_short TclWinNToHS(u_short ns)
}
declare 7 win {
- int TclWinSetSockOpt(int s, int level, int optname,
- CONST char FAR *optval, int optlen)
+ int TclWinSetSockOpt(SOCKET s, int level, int optname,
+ const char FAR *optval, int optlen)
}
declare 8 win {
unsigned long TclpGetPid(Tcl_Pid pid)
@@ -1009,7 +1070,7 @@ declare 14 win {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 15 win {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv,
+ int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv,
TclFile inputFile, TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr)
}
@@ -1024,7 +1085,7 @@ declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
- TclFile TclpOpenFile(CONST char *fname, int mode)
+ TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(void *hProcess, unsigned long id)
@@ -1037,7 +1098,7 @@ declare 20 win {
# Added in 8.1:
declare 22 win {
- TclFile TclpCreateTempFile(CONST char *contents)
+ TclFile TclpCreateTempFile(const char *contents)
}
declare 23 win {
char *TclpGetTZName(int isdst)
@@ -1045,7 +1106,7 @@ declare 23 win {
declare 24 win {
char *TclWinNoBackslash(char *path)
}
-# replaced by generic TclGetPlatform
+# replaced by TclGetPlatform
#declare 25 win {
# TclPlatformType *TclWinGetPlatform(void)
#}
@@ -1087,7 +1148,7 @@ declare 3 unix {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv,
+ int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv,
TclFile inputFile, TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr)
}
@@ -1099,7 +1160,7 @@ declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
- TclFile TclpOpenFile(CONST char *fname, int mode)
+ TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
@@ -1108,7 +1169,7 @@ declare 8 unix {
# Added in 8.1:
declare 9 unix {
- TclFile TclpCreateTempFile(CONST char *contents)
+ TclFile TclpCreateTempFile(const char *contents)
}
# Added in 8.4:
@@ -1117,12 +1178,12 @@ declare 10 unix {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
-# generic Stubs
+# Stubs
declare 11 unix {
- struct tm *TclpLocaltime_unix(CONST time_t *clock)
+ struct tm *TclpLocaltime_unix(const time_t *clock)
}
declare 12 unix {
- struct tm *TclpGmtime_unix(CONST time_t *clock)
+ struct tm *TclpGmtime_unix(const time_t *clock)
}
declare 13 unix {
char *TclpInetNtoa(struct in_addr addr)
@@ -1131,8 +1192,8 @@ declare 13 unix {
# Added in 8.5:
declare 14 unix {
- int TclUnixCopyFile(CONST char *src, CONST char *dst,
- CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts)
+ int TclUnixCopyFile(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
@@ -1147,16 +1208,16 @@ declare 16 macosx {
Tcl_Obj *fileName, Tcl_Obj *attributePtr)
}
declare 17 macosx {
- int TclMacOSXCopyFileAttributes(CONST char *src, CONST char *dst,
- CONST Tcl_StatBuf *statBufPtr)
+ int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr)
}
declare 18 macosx {
- int TclMacOSXMatchType(Tcl_Interp *interp, CONST char *pathName,
- CONST char *fileName, Tcl_StatBuf *statBufPtr,
+ int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
+ const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 macosx {
- void TclMacOSXNotifierAddRunLoopMode(CONST void *runLoopMode)
+ void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a560fe8..7d9f066 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -9,6 +9,8 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,8 +19,6 @@
#ifndef _TCLINT
#define _TCLINT
-#define TCL_NO_STACK_CHECK /* DISABLE C RUNTIME STACK CHECK - Test AIX */
-
/*
* Some numerics configuration options.
*/
@@ -202,6 +202,14 @@ typedef struct TclVarHashTable {
#define TclVarHashFindVar(tablePtr, key) \
TclVarHashCreateVar((tablePtr), (key), NULL)
+/*
+ * Define this to reduce the amount of space that the average namespace
+ * consumes by only allocating the table of child namespaces when necessary.
+ * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which
+ * reach directly into the Namespace structure.
+ */
+
+#undef BREAK_NAMESPACE_COMPAT
/*
* The structure below defines a namespace.
@@ -225,8 +233,15 @@ typedef struct Namespace {
struct Namespace *parentPtr;/* Points to the namespace that contains this
* one. NULL if this is the global
* namespace. */
+#ifndef BREAK_NAMESPACE_COMPAT
Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). */
+#else
+ Tcl_HashTable *childTablePtr;
+ /* Contains any child namespaces. Indexed by
+ * strings; values have type (Namespace *). If
+ * NULL, there are no children. */
+#endif
long nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
@@ -311,6 +326,12 @@ typedef struct Namespace {
NamespacePathEntry *commandPathSourceList;
/* Linked list of path entries that point to
* this namespace. */
+ Tcl_NamespaceDeleteProc *earlyDeleteProc;
+ /* Just like the deleteProc field (and called
+ * with the same clientData) but called at the
+ * start of the deletion process, so there is
+ * a chance for code to do stuff inside the
+ * namespace before deletion completes. */
} Namespace;
/*
@@ -349,13 +370,17 @@ struct NamespacePathEntry {
* unit that refers to the namespace has been freed (i.e., when
* the namespace's refCount is 0), the namespace's storage will
* be freed.
- * NS_KILLED 1 means that TclTeardownNamespace has already been called on
- * this namespace and it should not be called again [Bug 1355942]
+ * NS_KILLED - 1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942]
+ * NS_SUPPRESS_COMPILATION -
+ * Marks the commands in this namespace for not being compiled,
+ * forcing them to be looked up every time.
*/
#define NS_DYING 0x01
#define NS_DEAD 0x02
#define NS_KILLED 0x04
+#define NS_SUPPRESS_COMPILATION 0x08
/*
* Flags passed to TclGetNamespaceForQualName:
@@ -391,10 +416,91 @@ typedef struct {
} EnsembleCmdRep;
/*
- * Flag to enable bytecode compilation of an ensemble.
+ * The client data for an ensemble command. This consists of the table of
+ * commands that are actually exported by the namespace, and an epoch counter
+ * that, combined with the exportLookupEpoch field of the namespace structure,
+ * defines whether the table contains valid data or will need to be recomputed
+ * next time the ensemble command is called.
+ */
+
+typedef struct EnsembleConfig {
+ Namespace *nsPtr; /* The namspace backing this ensemble up. */
+ Tcl_Command token; /* The token for the command that provides
+ * ensemble support for the namespace, or NULL
+ * if the command has been deleted (or never
+ * existed; the global namespace never has an
+ * ensemble command.) */
+ int epoch; /* The epoch at which this ensemble's table of
+ * exported commands is valid. */
+ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
+ * consistent points, this will have the same
+ * number of entries as there are entries in
+ * the subcommandTable hash. */
+ Tcl_HashTable subcommandTable;
+ /* Hash table of ensemble subcommand names,
+ * which are its keys so this also provides
+ * the storage management for those subcommand
+ * names. The contents of the entry values are
+ * object version the prefix lists to use when
+ * substituting for the command/subcommand to
+ * build the ensemble implementation command.
+ * Has to be stored here as well as in
+ * subcommandDict because that field is NULL
+ * when we are deriving the ensemble from the
+ * namespace exports list. FUTURE WORK: use
+ * object hash table here. */
+ struct EnsembleConfig *next;/* The next ensemble in the linked list of
+ * ensembles associated with a namespace. If
+ * this field points to this ensemble, the
+ * structure has already been unlinked from
+ * all lists, and cannot be found by scanning
+ * the list from the namespace's ensemble
+ * field. */
+ int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX,
+ * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */
+
+ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
+
+ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
+ * subcommands to their implementing command
+ * prefixes, or NULL if we are to build the
+ * map automatically from the namespace
+ * exports. */
+ Tcl_Obj *subcmdList; /* List of commands that this ensemble
+ * actually provides, and whose implementation
+ * will be built using the subcommandDict (if
+ * present and defined) and by simple mapping
+ * to the namespace otherwise. If NULL,
+ * indicates that we are using the (dynamic)
+ * list of currently exported commands. */
+ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
+ * no match is found (according to the rule
+ * defined by flag bit TCL_ENSEMBLE_PREFIX) or
+ * NULL to use the default error-generating
+ * behaviour. The script execution gets all
+ * the arguments to the ensemble command
+ * (including objv[0]) and will have the
+ * results passed directly back to the caller
+ * (including the error code) unless the code
+ * is TCL_CONTINUE in which case the
+ * subcommand will be reparsed by the ensemble
+ * core, presumably because the ensemble
+ * itself has been updated. */
+ Tcl_Obj *parameterList; /* List of ensemble parameter names. */
+ int numParameters; /* Cached number of parameters. This is either
+ * 0 (if the parameterList field is NULL) or
+ * the length of the list in the parameterList
+ * field. */
+} EnsembleConfig;
+
+/*
+ * Various bits for the EnsembleConfig.flags field.
*/
-#define ENSEMBLE_COMPILE 0x4
+#define ENSEMBLE_DEAD 0x1 /* Flag value to say that the ensemble is dead
+ * and on its way out. */
+#define ENSEMBLE_COMPILE 0x4 /* Flag to enable bytecode compilation of an
+ * ensemble. */
/*
*----------------------------------------------------------------
@@ -776,6 +882,9 @@ typedef struct VarInHash {
#define TclIsVarDirectWritable(varPtr) \
!((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+#define TclIsVarDirectUnsettable(varPtr) \
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
+
#define TclIsVarDirectModifyable(varPtr) \
( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
&& (varPtr)->value.objPtr)
@@ -843,7 +952,7 @@ typedef struct CompiledLocal {
* is marked by a unique ClientData tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
- char name[4]; /* Name of the local variable starts here. If
+ char name[1]; /* Name of the local variable starts here. If
* the name is NULL, this will just be '\0'.
* The actual size of this field will be large
* enough to hold the name. MUST BE THE LAST
@@ -890,7 +999,7 @@ typedef struct Proc {
* of a procedure (or lambda term or ...).
*/
-typedef void (*ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
+typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
/*
* The structure below defines a command trace. This is used to allow Tcl
@@ -1041,10 +1150,20 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
+ struct NRE_callback *tailcallPtr;
+ /* NULL if no tailcall is scheduled */
} CallFrame;
#define FRAME_IS_PROC 0x1
#define FRAME_IS_LAMBDA 0x2
+#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
+ * clientData field contains a CallContext
+ * reference. Part of TIP#257. */
+#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
+ * the [oo::define] command; the clientData
+ * field contains an Object reference that has
+ * been confirmed to refer to a class. Part of
+ * TIP#257. */
/*
* TIP #280
@@ -1124,6 +1243,13 @@ typedef struct CmdFrame {
} str;
Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */
} cmd;
+ int numLevels; /* Value of interp's numLevels when the frame
+ * was pushed. */
+ const struct CFWordBC *litarg;
+ /* Link to set of literal arguments which have
+ * ben pushed on the lineLABCPtr stack by
+ * TclArgumentBCEnter(). These will be removed
+ * by TclArgumentBCRelease. */
} CmdFrame;
typedef struct CFWord {
@@ -1140,6 +1266,9 @@ typedef struct CFWordBC {
int word; /* Index of word in
* ExtCmdLoc.loc[cmd]->line[.] */
struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
+ struct CFWordBC *nextPtr; /* Next entry for same command call. See
+ * CmdFrame litarg field for the list start. */
+ Tcl_Obj *obj; /* Back reference to hashtable key */
} CFWordBC;
/*
@@ -1207,10 +1336,10 @@ typedef struct ContLineLoc {
* by [info frame]. Contains a sub-structure for each extra field.
*/
-typedef Tcl_Obj *(*GetFrameInfoValueProc)(ClientData clientData);
+typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
typedef struct {
const char *name; /* Name of this field. */
- GetFrameInfoValueProc proc; /* Function to generate a Tcl_Obj* from the
+ GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
ClientData clientData; /* Context for above function, or Tcl_Obj* if
@@ -1329,12 +1458,48 @@ typedef struct ExecStack {
* currently active execution stack.
*/
+typedef struct CorContext {
+ struct CallFrame *framePtr;
+ struct CallFrame *varFramePtr;
+ struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */
+ Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
+} CorContext;
+
+typedef struct CoroutineData {
+ struct Command *cmdPtr; /* The command handle for the coroutine. */
+ struct ExecEnv *eePtr; /* The special execution environment (stacks,
+ * etc.) for the coroutine. */
+ struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
+ * the coroutine, which might be the
+ * interpreter global environment or another
+ * coroutine. */
+ CorContext caller;
+ CorContext running;
+ Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
+ void *stackLevel;
+ int auxNumLevels; /* While the coroutine is running the
+ * numLevels of the create/resume command is
+ * stored here; for suspended coroutines it
+ * holds the nesting numLevels at yield. */
+ int nargs; /* Number of args required for resuming this
+ * coroutine; -2 means "0 or 1" (default), -1
+ * means "any" */
+} CoroutineData;
+
typedef struct ExecEnv {
ExecStack *execStackPtr; /* Points to the first item in the evaluation
* stack on the heap. */
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
+ struct Tcl_Interp *interp;
+ struct NRE_callback *callbackPtr;
+ /* Top callback in NRE's stack. */
+ struct CoroutineData *corPtr;
+ int rewind;
} ExecEnv;
+#define COR_IS_SUSPENDED(corPtr) \
+ ((corPtr)->stackLevel == NULL)
+
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
* interpreter contains a LiteralTable. It is used to reduce the storage
@@ -1432,6 +1597,10 @@ typedef struct {
const char *name; /* The name of the subcommand. */
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
+ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
+ ClientData clientData; /* Any clientData to give the command. */
+ int unsafe; /* Whether this command is to be hidden by
+ * default in a safe interpreter. */
} EnsembleImplMap;
/*
@@ -1524,6 +1693,7 @@ typedef struct Command {
* command. */
CommandTrace *tracePtr; /* First in list of all traces set for this
* command. */
+ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
} Command;
/*
@@ -1599,6 +1769,24 @@ enum PkgPreferOptions {
/*
*----------------------------------------------------------------
+ * This structure shadows the first few fields of the memory cache for the
+ * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the
+ * definition there.
+ * Some macros require knowledge of some fields in the struct in order to
+ * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer
+ * to the relevant fields is kept in the objCache field in struct Interp.
+ *----------------------------------------------------------------
+ */
+
+typedef struct AllocCache {
+ struct Cache *nextPtr; /* Linked list of cache entries. */
+ Tcl_ThreadId owner; /* Which thread's cache is this? */
+ Tcl_Obj *firstObjPtr; /* List of free objects for thread. */
+ int numObjects; /* Number of objects for thread. */
+} AllocCache;
+
+/*
+ *----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of commands
* plus other state information related to interpreting commands, such as
* variable storage. Primary responsibility for this data structure is in
@@ -1636,7 +1824,7 @@ typedef struct Interp {
int errorLine; /* When TCL_ERROR is returned, this gives the
* line number in the command where the error
* occurred (1 means first line). */
- struct TclStubs *stubTable;
+ const struct TclStubs *stubTable;
/* Pointer to the exported Tcl stub table. On
* previous versions of Tcl this is a pointer
* to the objResultPtr or a pointer to a
@@ -1930,23 +2118,55 @@ typedef struct Interp {
* They are used by the macros defined below.
*/
- void *allocCache;
+ AllocCache *allocCache;
void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
* structs for this interp's thread; see
* tclObj.c and tclThreadAlloc.c */
int *asyncReadyPtr; /* Pointer to the asyncReady indicator for
* this interp's thread; see tclAsync.c */
- int *stackBound; /* Pointer to the limit stack address
- * allowable for invoking a new command
- * without "risking" a C-stack overflow; see
- * TclpCheckStackSpace in the platform's
- * directory. */
+ /*
+ * The pointer to the object system root ekeko. c.f. TIP #257.
+ */
+ void *objectFoundation; /* Pointer to the Foundation structure of the
+ * object system, which contains things like
+ * references to key namespaces. See
+ * tclOOInt.h and tclOO.c for real definition
+ * and setup. */
+
+ struct NRE_callback *deferredCallbacks;
+ /* Callbacks that are set previous to a call
+ * to some Eval function but that actually
+ * belong to the command that is about to be
+ * called - i.e., they should be run *before*
+ * any tailcall is invoked. */
+ /*
+ * TIP #285, Script cancellation support.
+ */
+
+ Tcl_AsyncHandler asyncCancel;
+ /* Async handler token for Tcl_CancelEval. */
+ Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler
+ * for the propagation of arbitrary Tcl
+ * errors. This information, if present
+ * (asyncCancelMsg not NULL), takes precedence
+ * over the default error messages returned by
+ * a script cancellation operation. */
+
+ /*
+ * TIP #348 IMPLEMENTATION - Substituted error stack
+ */
+ Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */
+ Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */
+ Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */
+ Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */
+ Tcl_Obj *innerContext; /* cached list for fast reallocation */
+ int resetErrorStack; /* controls cleaning up of ::errorStack */
#ifdef TCL_COMPILE_STATS
/*
* Statistical information about the bytecode compiler and interpreter's
- * operation.
+ * operation. This should be the last field of Interp.
*/
ByteCodeStats stats; /* Holds compilation and execution statistics
@@ -1962,6 +2182,22 @@ typedef struct Interp {
*((iPtr)->asyncReadyPtr)
/*
+ * Macros for script cancellation support (TIP #285).
+ */
+
+#define TclCanceled(iPtr) \
+ (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND))
+
+#define TclSetCancelFlags(iPtr, cancelFlags) \
+ (iPtr)->flags |= CANCELED; \
+ if ((cancelFlags) & TCL_CANCEL_UNWIND) { \
+ (iPtr)->flags |= TCL_CANCEL_UNWIND; \
+ }
+
+#define TclUnsetCancelFlags(iPtr) \
+ (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND))
+
+/*
* General list of interpreters. Doubly linked for easier removal of items
* deep in the list.
*/
@@ -2010,6 +2246,7 @@ typedef struct InterpList {
#define TCL_ALLOW_EXCEPTIONS 4
#define TCL_EVAL_FILE 2
#define TCL_EVAL_CTX 8
+#define TCL_EVAL_REDIRECT 16
/*
* Flag bits for Interp structures:
@@ -2042,6 +2279,16 @@ typedef struct InterpList {
* of the wrong-num-args string in Tcl_WrongNumArgs.
* Makes it append instead of replacing and uses
* different intermediate text.
+ * CANCELED: Non-zero means that the script in progress should be
+ * canceled as soon as possible. This can be checked by
+ * extensions (and the core itself) by calling
+ * Tcl_Canceled and checking if TCL_ERROR is returned.
+ * This is a one-shot flag that is reset immediately upon
+ * being detected; however, if the TCL_CANCEL_UNWIND flag
+ * is set Tcl_Canceled will continue to report that the
+ * script in progress has been canceled thereby allowing
+ * the evaluation stack for the interp to be fully
+ * unwound.
*
* WARNING: For the sake of some extensions that have made use of former
* internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
@@ -2057,6 +2304,7 @@ typedef struct InterpList {
#define INTERP_TRACE_IN_PROGRESS 0x200
#define INTERP_ALTERNATE_WRONG_ARGS 0x400
#define ERR_LEGACY_COPY 0x800
+#define CANCELED 0x1000
/*
* Maximum number of levels of nesting permitted in Tcl commands (used to
@@ -2351,10 +2599,10 @@ typedef enum Tcl_PathPart {
*----------------------------------------------------------------
*/
-typedef int (TclStatProc_)(CONST char *path, struct stat *buf);
-typedef int (TclAccessProc_)(CONST char *path, int mode);
+typedef int (TclStatProc_)(const char *path, struct stat *buf);
+typedef int (TclAccessProc_)(const char *path, int mode);
typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
- CONST char *fileName, CONST char *modeString, int permissions);
+ const char *fileName, const char *modeString, int permissions);
/*
*----------------------------------------------------------------
@@ -2419,6 +2667,8 @@ typedef struct ProcessGlobalValue {
* prefixes. */
#define TCL_PARSE_NO_WHITESPACE 32
/* Reject leading/trailing whitespace. */
+#define TCL_PARSE_BINARY_ONLY 64
+ /* Parse binary even without prefix. */
/*
*----------------------------------------------------------------------
@@ -2442,7 +2692,7 @@ MODULE_SCOPE char *tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
-MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier;
+MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks;
/*
* TIP #233 (Virtualized Time)
@@ -2457,32 +2707,33 @@ MODULE_SCOPE ClientData tclTimeClientData;
* Variables denoting the Tcl object types defined in the core.
*/
-MODULE_SCOPE Tcl_ObjType tclBignumType;
-MODULE_SCOPE Tcl_ObjType tclBooleanType;
-MODULE_SCOPE Tcl_ObjType tclByteArrayType;
-MODULE_SCOPE Tcl_ObjType tclByteCodeType;
-MODULE_SCOPE Tcl_ObjType tclDoubleType;
-MODULE_SCOPE Tcl_ObjType tclEndOffsetType;
-MODULE_SCOPE Tcl_ObjType tclIntType;
-MODULE_SCOPE Tcl_ObjType tclListType;
-MODULE_SCOPE Tcl_ObjType tclDictType;
-MODULE_SCOPE Tcl_ObjType tclProcBodyType;
-MODULE_SCOPE Tcl_ObjType tclStringType;
-MODULE_SCOPE Tcl_ObjType tclArraySearchType;
-MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType;
+MODULE_SCOPE const Tcl_ObjType tclBignumType;
+MODULE_SCOPE const Tcl_ObjType tclBooleanType;
+MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
+MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
+MODULE_SCOPE const Tcl_ObjType tclDoubleType;
+MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
+MODULE_SCOPE const Tcl_ObjType tclIntType;
+MODULE_SCOPE const Tcl_ObjType tclListType;
+MODULE_SCOPE const Tcl_ObjType tclDictType;
+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
-MODULE_SCOPE Tcl_ObjType tclWideIntType;
+MODULE_SCOPE const Tcl_ObjType tclWideIntType;
#endif
-MODULE_SCOPE Tcl_ObjType tclRegexpType;
+MODULE_SCOPE const Tcl_ObjType tclRegexpType;
+MODULE_SCOPE Tcl_ObjType tclCmdNameType;
/*
* Variables denoting the hash key types defined in the core.
*/
-MODULE_SCOPE Tcl_HashKeyType tclArrayHashKeyType;
-MODULE_SCOPE Tcl_HashKeyType tclOneWordHashKeyType;
-MODULE_SCOPE Tcl_HashKeyType tclStringHashKeyType;
-MODULE_SCOPE Tcl_HashKeyType tclObjHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
/*
* The head of the list of free Tcl objects, and the total number of Tcl
@@ -2507,6 +2758,73 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
+/*
+ *----------------------------------------------------------------
+ * Procedures shared among Tcl modules but not used by the outside world,
+ * introduced by/for NRE.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
+
+MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
+
+MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
+ struct NRE_callback *tailcallPtr);
+
+/*
+ * This structure holds the data for the various iteration callbacks used to
+ * NRE the 'for' and 'while' commands. We need a separate structure because we
+ * have more than the 4 client data entries we can provide directly thorugh
+ * the callback API. It is the 'word' information which puts us over the
+ * limit. It is needed because the loop body is argument 4 of 'for' and
+ * argument 2 of 'while'. Not providing the correct index confuses the #280
+ * code. We TclSmallAlloc/Free this.
+ */
+
+typedef struct ForIterData {
+ Tcl_Obj *cond; /* Loop condition expression. */
+ Tcl_Obj *body; /* Loop body. */
+ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
+ const char *msg; /* Error message part. */
+ int word; /* Index of the body script in the command */
+} ForIterData;
+
+/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
+ * and Tcl_FindSymbol. This structure corresponds to an opaque
+ * typedef in tcl.h */
+
+typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
+ const char* symbol);
+struct Tcl_LoadHandle_ {
+ ClientData clientData; /* Client data is the load handle in the
+ * native filesystem if a module was loaded
+ * there, or an opaque pointer to a structure
+ * for further bookkeeping on load-from-VFS
+ * and load-from-memory */
+ TclFindSymbolProc* findSymbolProcPtr;
+ /* Procedure that resolves symbols in a
+ * loaded module */
+ Tcl_FSUnloadFileProc* unloadFileProcPtr;
+ /* Procedure that unloads a loaded module */
+};
+
/* Flags for conversion of doubles to digit strings */
#define TCL_DD_SHORTEST 0x4
@@ -2539,38 +2857,47 @@ MODULE_SCOPE char tclEmptyString;
*----------------------------------------------------------------
*/
-MODULE_SCOPE void TclAdvanceContinuations(int* line, int** next, int loc);
-MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
+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,
const char *end);
-MODULE_SCOPE void TclArgumentEnter(Tcl_Interp* interp,
- Tcl_Obj* objv[], int objc, CmdFrame* cf);
-MODULE_SCOPE void TclArgumentRelease(Tcl_Interp* interp,
- Tcl_Obj* objv[], int objc);
-MODULE_SCOPE void TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj,
- CmdFrame **cfPtrPtr, int *wordPtr);
-MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
- Tcl_Obj* objv[], int objc,
- void *codePtr, CmdFrame *cfPtr, int pc);
-MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
+MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
+ Tcl_Obj *objv[], int objc, CmdFrame *cf);
+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, int pc);
+ void *codePtr, CmdFrame *cfPtr, int pc);
+MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
+ CmdFrame *cfPtr);
+MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
+ CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
-MODULE_SCOPE double TclBignumToDouble(mp_int *bignum);
+MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum);
MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
int strLen, const unsigned char *pattern,
int ptnLen, int flags);
-MODULE_SCOPE double TclCeil(mp_int *a);
-MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value);
+MODULE_SCOPE double TclCeil(const mp_int *a);
+MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
+ const char *value);
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
+MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
+MODULE_SCOPE int TclClearRootEnsemble(ClientData data[],
+ Tcl_Interp *interp, int result);
MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
-MODULE_SCOPE ContLineLoc* TclContinuationsEnter(Tcl_Obj *objPtr, int num,
+MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
int start, int *clNext);
-MODULE_SCOPE ContLineLoc* TclContinuationsGet(Tcl_Obj *objPtr);
+MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclCountSpaceRuns(CONST char *bytes, int numBytes,
@@ -2579,17 +2906,15 @@ MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
/* TIP #280 - Modified token based evulation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
- int *clNextOuter, CONST char *outerScript);
-MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+ int *clNextOuter, const char *outerScript);
+MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
@@ -2599,6 +2924,7 @@ MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
MODULE_SCOPE void TclFinalizeEncodingSubsystem(void);
MODULE_SCOPE void TclFinalizeEnvironment(void);
+MODULE_SCOPE void TclFinalizeEvaluation(void);
MODULE_SCOPE void TclFinalizeExecution(void);
MODULE_SCOPE void TclFinalizeIOSubsystem(void);
MODULE_SCOPE void TclFinalizeFilesystem(void);
@@ -2613,16 +2939,20 @@ MODULE_SCOPE void TclFinalizeSynchronization(void);
MODULE_SCOPE void TclFinalizeThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadData(void);
MODULE_SCOPE void TclFinalizeThreadObjects(void);
-MODULE_SCOPE double TclFloor(mp_int *a);
+MODULE_SCOPE double TclFloor(const mp_int *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
const char *attributeName, int *indexPtr);
+MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
int *modePtr, int flags);
+MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp,
+ Tcl_Obj *value, int *code);
MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData *clientDataPtr,
int *typePtr);
@@ -2640,6 +2970,8 @@ MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -2672,12 +3004,6 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n,
int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
-MODULE_SCOPE int TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
- int symc, const char *symbols[],
- Tcl_PackageInitProc **procPtrs[],
- Tcl_LoadHandle *handlePtr,
- ClientData *clientDataPtr,
- Tcl_FSUnloadFileProc **unloadProcPtr);
MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
@@ -2688,7 +3014,8 @@ MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
int *codePtr, int *levelPtr);
-MODULE_SCOPE int TclNokia770Doubles();
+MODULE_SCOPE int TclNokia770Doubles(void);
+MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const char *operation,
const char *reason, int index);
@@ -2709,20 +3036,22 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string,
MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
-#ifndef TCL_NO_STACK_CHECK
-MODULE_SCOPE int TclpGetCStackParams(int **stackBoundPtr);
-#endif
MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
+MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
int len);
-MODULE_SCOPE int TclpDeleteFile(const char *path);
+MODULE_SCOPE int TclpDeleteFile(const void *path);
MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr);
MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void TclpFinalizePipes(void);
MODULE_SCOPE void TclpFinalizeSockets(void);
+MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp,
+ struct addrinfo **addrlist,
+ const char *host, int port, int willBind,
+ const char **errorMsgPtr);
MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
- Tcl_ThreadCreateProc proc, ClientData clientData,
+ Tcl_ThreadCreateProc *proc, ClientData clientData,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
@@ -2743,7 +3072,7 @@ MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators,
Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp,
Tcl_Obj *pathPtr, int nextCheckpoint);
-MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, char *joining);
+MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
@@ -2757,24 +3086,19 @@ MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
int linkType);
MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr);
+MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
+ Tcl_Obj *resultingNameObj);
MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
-#ifndef TclpPanic
-MODULE_SCOPE void TclpPanic(const char *format, ...);
-#endif
MODULE_SCOPE char * TclpReadlink(const char *fileName,
Tcl_DString *linkPtr);
-#ifndef TclpReleaseFile
-MODULE_SCOPE void TclpReleaseFile(TclFile file);
-#endif
MODULE_SCOPE void TclpSetInterfaces(void);
MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
-MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle);
-MODULE_SCOPE void * TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);
-MODULE_SCOPE void TclpThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
+MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
+MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
void *data);
MODULE_SCOPE void TclpThreadExit(int status);
-MODULE_SCOPE size_t TclpThreadGetStackSize(void);
MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
@@ -2787,6 +3111,7 @@ MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
mp_int *bignumValue);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
+MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
@@ -2797,19 +3122,23 @@ MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
+MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
+ int numBytes, int flags, int line,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts,
+ Tcl_Obj *const opts[], int *flagPtr);
+MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
+ int numBytes, int flags, Tcl_Parse *parsePtr,
+ Tcl_InterpState *statePtr);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count, int *tokensLeftPtr, int line,
- int *clNextOuter, CONST char *outerScript);
-MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result,
- Tcl_Interp *targetInterp);
+ int *clNextOuter, const char *outerScript);
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 Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
-MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp,
- Tcl_LoadHandle loadHandle, const char *symbol);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr);
@@ -2821,13 +3150,20 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer,
Tcl_FSUnloadFileProc **unloadProcPtr);
#endif
MODULE_SCOPE void TclInitThreadStorage(void);
-MODULE_SCOPE void TclpFinalizeThreadDataThread(void);
+MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
+MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
+MODULE_SCOPE void * TclpThreadCreateKey(void);
+MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
+MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
+MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
+
+MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
/*
*----------------------------------------------------------------
@@ -2844,12 +3180,8 @@ MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_BinaryObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -2869,6 +3201,10 @@ MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
MODULE_SCOPE int TclClockOldscanObjCmd(
ClientData clientData, Tcl_Interp *interp,
@@ -2892,6 +3228,15 @@ MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+
+/* Assemble command function */
+MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -2922,9 +3267,8 @@ MODULE_SCOPE int Tcl_FconfigureObjCmd(
MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3004,7 +3348,8 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_NamespaceObjCmd(ClientData clientData,
+MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData,
@@ -3016,6 +3361,7 @@ MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3034,6 +3380,9 @@ MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3065,12 +3414,17 @@ MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3138,6 +3492,9 @@ MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileErrorCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3177,7 +3534,7 @@ MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclCompileNamespaceCmd(Tcl_Interp *interp,
+MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
@@ -3207,9 +3564,21 @@ MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringMatchCmd(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);
MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3358,6 +3727,10 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData,
MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+
+MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
/*
* Functions defined in generic/tclVar.c and currenttly exported only for use
@@ -3387,6 +3760,10 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp,
const int flags, int index);
MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr,
Tcl_Obj *myNamePtr, int myFlags, int index);
+MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags,
+ int index);
MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
/*
@@ -3431,7 +3808,10 @@ MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
*/
#ifdef USE_DTRACE
+#ifndef _TCLDTRACE_H
+typedef const char *TclDTraceStr;
#include "tclDTrace.h"
+#endif
#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr)
#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr)
#else /* USE_DTRACE */
@@ -3449,6 +3829,12 @@ MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
+# define TclAllocObjStorage(objPtr) \
+ TclAllocObjStorageEx(NULL, (objPtr))
+
+# define TclFreeObjStorage(objPtr) \
+ TclFreeObjStorageEx(NULL, (objPtr))
+
#ifndef TCL_MEM_DEBUG
# define TclNewObj(objPtr) \
TclIncrObjsAllocated(); \
@@ -3491,10 +3877,10 @@ MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
* track memory leaks.
*/
-# define TclAllocObjStorage(objPtr) \
+# define TclAllocObjStorageEx(interp, objPtr) \
(objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))
-# define TclFreeObjStorage(objPtr) \
+# define TclFreeObjStorageEx(interp, objPtr) \
ckfree((char *) (objPtr))
#undef USE_THREAD_ALLOC
@@ -3514,11 +3900,43 @@ MODULE_SCOPE void TclpSetAllocCache(void *);
MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void TclpFreeAllocCache(void *);
-# define TclAllocObjStorage(objPtr) \
- (objPtr) = TclThreadAllocObj()
-
-# define TclFreeObjStorage(objPtr) \
- TclThreadFreeObj((objPtr))
+/*
+ * These macros need to be kept in sync with the code of TclThreadAllocObj()
+ * and TclThreadFreeObj().
+ *
+ * Note that the optimiser should resolve the case (interp==NULL) at compile
+ * time.
+ */
+
+# define ALLOC_NOBJHIGH 1200
+
+# define TclAllocObjStorageEx(interp, objPtr) \
+ do { \
+ AllocCache *cachePtr; \
+ if (((interp) == NULL) || \
+ ((cachePtr = ((Interp *)(interp))->allocCache), \
+ (cachePtr->numObjects == 0))) { \
+ (objPtr) = TclThreadAllocObj(); \
+ } else { \
+ (objPtr) = cachePtr->firstObjPtr; \
+ cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \
+ --cachePtr->numObjects; \
+ } \
+ } while (0)
+
+# define TclFreeObjStorageEx(interp, objPtr) \
+ do { \
+ AllocCache *cachePtr; \
+ if (((interp) == NULL) || \
+ ((cachePtr = ((Interp *)(interp))->allocCache), \
+ (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \
+ TclThreadFreeObj(objPtr); \
+ } else { \
+ (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \
+ cachePtr->firstObjPtr = objPtr; \
+ ++cachePtr->numObjects; \
+ } \
+ } while (0)
#else /* not PURIFY or USE_THREAD_ALLOC */
@@ -3527,32 +3945,39 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
MODULE_SCOPE Tcl_Mutex tclObjMutex;
#endif
-# define TclAllocObjStorage(objPtr) \
- Tcl_MutexLock(&tclObjMutex); \
- if (tclFreeObjList == NULL) { \
- TclAllocateFreeObjects(); \
- } \
- (objPtr) = tclFreeObjList; \
- tclFreeObjList = (Tcl_Obj *) \
- tclFreeObjList->internalRep.otherValuePtr; \
- Tcl_MutexUnlock(&tclObjMutex)
-
-# define TclFreeObjStorage(objPtr) \
- Tcl_MutexLock(&tclObjMutex); \
+# define TclAllocObjStorageEx(interp, objPtr) \
+ do { \
+ Tcl_MutexLock(&tclObjMutex); \
+ if (tclFreeObjList == NULL) { \
+ TclAllocateFreeObjects(); \
+ } \
+ (objPtr) = tclFreeObjList; \
+ tclFreeObjList = (Tcl_Obj *) \
+ tclFreeObjList->internalRep.otherValuePtr; \
+ Tcl_MutexUnlock(&tclObjMutex); \
+ } while (0)
+
+# define TclFreeObjStorageEx(interp, objPtr) \
+ do { \
+ Tcl_MutexLock(&tclObjMutex); \
(objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \
- tclFreeObjList = (objPtr); \
- Tcl_MutexUnlock(&tclObjMutex)
+ tclFreeObjList = (objPtr); \
+ Tcl_MutexUnlock(&tclObjMutex); \
+ } while (0)
#endif
#else /* TCL_MEM_DEBUG */
-MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
+MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
int line);
# define TclDbNewObj(objPtr, file, line) \
- TclIncrObjsAllocated(); \
- (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
- TclDbInitNewObj((objPtr), (file), (line)); \
- TCL_DTRACE_OBJ_CREATE(objPtr)
+ do { \
+ TclIncrObjsAllocated(); \
+ (objPtr) = (Tcl_Obj *) \
+ Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
+ TclDbInitNewObj((objPtr), (file), (line)); \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
# define TclNewObj(objPtr) \
TclDbNewObj(objPtr, __FILE__, __LINE__);
@@ -3587,8 +4012,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
- memcpy((void *) (objPtr)->bytes, (void *) (bytePtr), \
- (unsigned) (len)); \
+ memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
@@ -3624,9 +4048,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
*/
#define TclFreeIntRep(objPtr) \
- if ((objPtr)->typePtr != NULL && \
- (objPtr)->typePtr->freeIntRepProc != NULL) { \
- (objPtr)->typePtr->freeIntRepProc(objPtr); \
+ if ((objPtr)->typePtr != NULL) { \
+ if ((objPtr)->typePtr->freeIntRepProc != NULL) { \
+ (objPtr)->typePtr->freeIntRepProc(objPtr); \
+ } \
+ (objPtr)->typePtr = NULL; \
}
/*
@@ -3663,40 +4089,40 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
#define TCL_MIN_TOKEN_GROWTH 50
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \
-{ \
- int needed = (used) + (append); \
- if (needed > TCL_MAX_TOKENS) { \
- Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \
- TCL_MAX_TOKENS); \
- } \
- if (needed > (available)) { \
- int allocated = 2 * needed; \
- Tcl_Token *oldPtr = (tokenPtr); \
- Tcl_Token *newPtr; \
- if (oldPtr == (staticPtr)) { \
- oldPtr = NULL; \
+ do { \
+ int needed = (used) + (append); \
+ if (needed > TCL_MAX_TOKENS) { \
+ Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \
+ TCL_MAX_TOKENS); \
} \
- if (allocated > TCL_MAX_TOKENS) { \
- allocated = TCL_MAX_TOKENS; \
- } \
- newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
- (unsigned int) (allocated * sizeof(Tcl_Token))); \
- if (newPtr == NULL) { \
- allocated = needed + (append) + TCL_MIN_TOKEN_GROWTH; \
+ if (needed > (available)) { \
+ int allocated = 2 * needed; \
+ Tcl_Token *oldPtr = (tokenPtr); \
+ Tcl_Token *newPtr; \
+ if (oldPtr == (staticPtr)) { \
+ oldPtr = NULL; \
+ } \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
- newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \
+ newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
(unsigned int) (allocated * sizeof(Tcl_Token))); \
+ if (newPtr == NULL) { \
+ allocated = needed + (append) + TCL_MIN_TOKEN_GROWTH; \
+ if (allocated > TCL_MAX_TOKENS) { \
+ allocated = TCL_MAX_TOKENS; \
+ } \
+ newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \
+ (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ } \
+ (available) = allocated; \
+ if (oldPtr == NULL) { \
+ memcpy(newPtr, staticPtr, \
+ (size_t) ((used) * sizeof(Tcl_Token))); \
+ } \
+ (tokenPtr) = newPtr; \
} \
- (available) = allocated; \
- if (oldPtr == NULL) { \
- memcpy((VOID *) newPtr, (VOID *) staticPtr, \
- (size_t) ((used) * sizeof(Tcl_Token))); \
- } \
- (tokenPtr) = newPtr; \
- } \
-}
+ } while (0)
#define TclGrowParseTokenArray(parsePtr, append) \
TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \
@@ -3722,6 +4148,48 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
/*
*----------------------------------------------------------------
+ * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
+ * -sensitive points where it pays to avoid a function call in the common case
+ * of counting along a string of all one-byte characters. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes,
+ * int numBytes);
+ *----------------------------------------------------------------
+ */
+
+#define TclNumUtfChars(numChars, bytes, numBytes) \
+ do { \
+ int count, i = (numBytes); \
+ unsigned char *str = (unsigned char *) (bytes); \
+ while (i && (*str < 0xC0)) { i--; str++; } \
+ count = (numBytes) - i; \
+ if (i) { \
+ count += Tcl_NumUtfChars((bytes) + count, i); \
+ } \
+ (numChars) = count; \
+ } while (0);
+
+/*
+ *----------------------------------------------------------------
+ * Macro that encapsulates the logic that determines when it is safe to
+ * interpret a string as a byte array directly. In summary, the object must be
+ * a byte array and must not have a string representation (as the operations
+ * that it is used in are defined on strings, not byte arrays). Theoretically
+ * it is possible to also be efficient in the case where the object's bytes
+ * field is filled by generation from the byte array (c.f. list canonicality)
+ * but we don't do that at the moment since this is purely about efficiency.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclIsPureByteArray(objPtr) \
+ (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
+
+/*
+ *----------------------------------------------------------------
* Macro used by the Tcl core to compare Unicode strings. On big-endian
* systems we can use the more efficient memcmp, but this would not be
* lexically correct on little-endian systems. The ANSI C "prototype" for
@@ -3748,8 +4216,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
*/
#define TclInvalidateNsCmdLookup(nsPtr) \
- if ((nsPtr)->numExportPatterns) { \
- (nsPtr)->exportLookupEpoch++; \
+ if ((nsPtr)->numExportPatterns) { \
+ (nsPtr)->exportLookupEpoch++; \
}
/*
@@ -3760,7 +4228,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
*----------------------------------------------------------------------
*/
-MODULE_SCOPE int TclTommath_Init(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int *bignum,
Tcl_WideInt initVal);
@@ -3768,6 +4236,22 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
Tcl_WideUInt initVal);
/*
+ *----------------------------------------------------------------------
+ *
+ * External (platform specific) initialization routine, these declarations
+ * explicitly don't use EXTERN since this code does not get compiled into the
+ * library:
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit;
+MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init;
+MODULE_SCOPE Tcl_PackageInitProc TclThread_Init;
+MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init;
+MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
+
+/*
*----------------------------------------------------------------
* Macro used by the Tcl core to check whether a pattern has any characters
* special to [string match]. The ANSI C "prototype" for this macro is:
@@ -3776,7 +4260,8 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
*----------------------------------------------------------------
*/
-#define TclMatchIsTrivial(pattern) strpbrk((pattern), "*[?\\") == NULL
+#define TclMatchIsTrivial(pattern) \
+ (strpbrk((pattern), "*[?\\") == NULL)
/*
*----------------------------------------------------------------
@@ -3794,10 +4279,12 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
*/
#define TclSetIntObj(objPtr, i) \
- TclInvalidateStringRep(objPtr);\
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.longValue = (long)(i); \
- (objPtr)->typePtr = &tclIntType
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->typePtr = &tclIntType; \
+ } while (0)
#define TclSetLongObj(objPtr, l) \
TclSetIntObj((objPtr), (l))
@@ -3814,17 +4301,21 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
#ifndef NO_WIDE_TYPE
#define TclSetWideIntObj(objPtr, w) \
- TclInvalidateStringRep(objPtr);\
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclWideIntType
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
+ (objPtr)->typePtr = &tclWideIntType; \
+ } while (0)
#endif
#define TclSetDoubleObj(objPtr, d) \
- TclInvalidateStringRep(objPtr);\
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->typePtr = &tclDoubleType; \
+ } while (0)
/*
*----------------------------------------------------------------
@@ -3845,13 +4336,15 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, i) \
- TclIncrObjsAllocated(); \
- TclAllocObjStorage(objPtr); \
- (objPtr)->refCount = 0; \
- (objPtr)->bytes = NULL; \
- (objPtr)->internalRep.longValue = (long)(i); \
- (objPtr)->typePtr = &tclIntType; \
- TCL_DTRACE_OBJ_CREATE(objPtr)
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->typePtr = &tclIntType; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
#define TclNewLongObj(objPtr, l) \
TclNewIntObj((objPtr), (l))
@@ -3864,21 +4357,25 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
TclNewIntObj((objPtr), ((b)? 1 : 0))
#define TclNewDoubleObj(objPtr, d) \
- TclIncrObjsAllocated(); \
- TclAllocObjStorage(objPtr); \
- (objPtr)->refCount = 0; \
- (objPtr)->bytes = NULL; \
- (objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType; \
- TCL_DTRACE_OBJ_CREATE(objPtr)
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->typePtr = &tclDoubleType; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
#define TclNewStringObj(objPtr, s, len) \
- TclIncrObjsAllocated(); \
- TclAllocObjStorage(objPtr); \
- (objPtr)->refCount = 0; \
- TclInitStringRep((objPtr), (s), (len));\
- (objPtr)->typePtr = NULL; \
- TCL_DTRACE_OBJ_CREATE(objPtr)
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ TclInitStringRep((objPtr), (s), (len)); \
+ (objPtr)->typePtr = NULL; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, i) \
@@ -3982,11 +4479,184 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
((limit).granularityTicker % (limit).timeGranularity == 0)))\
? 1 : 0)))
+/*
+ * Compile-time assertions: these produce a compile time error if the
+ * expression is not known to be true at compile time. If the assertion is
+ * known to be false, the compiler (or optimizer?) will error out with
+ * "division by zero". If the assertion cannot be evaluated at compile time,
+ * the compiler will error out with "non-static initializer".
+ *
+ * Adapted with permission from
+ * http://www.pixelbeat.org/programming/gcc/static_assert.html
+ */
+
+#define TCL_CT_ASSERT(e) \
+ {enum { ct_assert_value = 1/(!!(e)) };}
+
+/*
+ *----------------------------------------------------------------
+ * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool.
+ * Only checked at compile time.
+ *
+ * ONLY USE FOR CONSTANT nBytes.
+ *
+ * DO NOT LET THEM CROSS THREAD BOUNDARIES
+ *----------------------------------------------------------------
+ */
+
+#define TclSmallAlloc(nbytes, memPtr) \
+ TclSmallAllocEx(NULL, (nbytes), (memPtr))
+
+#define TclSmallFree(memPtr) \
+ TclSmallFreeEx(NULL, (memPtr))
+
+#ifndef TCL_MEM_DEBUG
+#define TclSmallAllocEx(interp, nbytes, memPtr) \
+ do { \
+ Tcl_Obj *objPtr; \
+ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorageEx((interp), (objPtr)); \
+ memPtr = (ClientData) (objPtr); \
+ } while (0)
+
+#define TclSmallFreeEx(interp, memPtr) \
+ do { \
+ TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
+ TclIncrObjsFreed(); \
+ } while (0)
+
+#else /* TCL_MEM_DEBUG */
+#define TclSmallAllocEx(interp, nbytes, memPtr) \
+ do { \
+ Tcl_Obj *objPtr; \
+ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
+ TclNewObj(objPtr); \
+ memPtr = (ClientData) objPtr; \
+ } while (0)
+
+#define TclSmallFreeEx(interp, memPtr) \
+ do { \
+ Tcl_Obj *objPtr = (Tcl_Obj *) memPtr; \
+ objPtr->bytes = NULL; \
+ objPtr->typePtr = NULL; \
+ objPtr->refCount = 1; \
+ TclDecrRefCount(objPtr); \
+ } while (0)
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
+ */
+
+#if defined(PURIFY) && defined(__clang__)
+#if __has_feature(attribute_analyzer_noreturn) && \
+ !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
+void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
+#endif
+#if !defined(CLANG_ASSERT)
+#include <assert.h>
+#define CLANG_ASSERT(x) assert(x)
+#endif
+#elif !defined(CLANG_ASSERT)
+#define CLANG_ASSERT(x)
+#endif /* PURIFY && __clang__ */
+
+/*
+ *----------------------------------------------------------------
+ * Parameters, structs and macros for the non-recursive engine (NRE)
+ *----------------------------------------------------------------
+ */
+
+#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */
+#define NRE_ENABLE_ASSERTS 1
+
+/*
+ * This is the main data struct for representing NR commands. It is designed
+ * to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator
+ * available.
+ */
+
+typedef struct NRE_callback {
+ Tcl_NRPostProc *procPtr;
+ ClientData data[4];
+ struct NRE_callback *nextPtr;
+} NRE_callback;
+
+#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
+
+/*
+ * Inline version of Tcl_NRAddCallback.
+ */
+
+#define TclNRAddCallback(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 = TOP_CB(interp); \
+ 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))
+#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr))
+#else
+#define TCLNR_ALLOC(interp, ptr) \
+ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
+#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#endif
+
+#if NRE_ENABLE_ASSERTS
+#define NRE_ASSERT(expr) assert((expr))
+#else
+#define NRE_ASSERT(expr)
+#endif
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
#include "tclTomMathDecls.h"
+#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
+#define Tcl_AttemptAlloc(size) TclpAlloc(size)
+#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size))
+#define Tcl_Free(ptr) TclpFree(ptr)
+#endif
+
#endif /* _TCLINT */
/*
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index fb63ec0..b294e4f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -58,778 +58,403 @@
/* Slot 0 is reserved */
/* Slot 1 is reserved */
/* Slot 2 is reserved */
-#ifndef TclAllocateFreeObjects_TCL_DECLARED
-#define TclAllocateFreeObjects_TCL_DECLARED
/* 3 */
EXTERN void TclAllocateFreeObjects(void);
-#endif
/* Slot 4 is reserved */
-#ifndef TclCleanupChildren_TCL_DECLARED
-#define TclCleanupChildren_TCL_DECLARED
/* 5 */
EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids,
Tcl_Pid *pidPtr, Tcl_Channel errorChan);
-#endif
-#ifndef TclCleanupCommand_TCL_DECLARED
-#define TclCleanupCommand_TCL_DECLARED
/* 6 */
EXTERN void TclCleanupCommand(Command *cmdPtr);
-#endif
-#ifndef TclCopyAndCollapse_TCL_DECLARED
-#define TclCopyAndCollapse_TCL_DECLARED
/* 7 */
-EXTERN int TclCopyAndCollapse(int count, CONST char *src,
+EXTERN int TclCopyAndCollapse(int count, const char *src,
char *dst);
-#endif
-#ifndef TclCopyChannel_TCL_DECLARED
-#define TclCopyChannel_TCL_DECLARED
/* 8 */
-EXTERN int TclCopyChannel(Tcl_Interp *interp,
+EXTERN int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
-#endif
-#ifndef TclCreatePipeline_TCL_DECLARED
-#define TclCreatePipeline_TCL_DECLARED
/* 9 */
EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc,
- CONST char **argv, Tcl_Pid **pidArrayPtr,
+ const char **argv, Tcl_Pid **pidArrayPtr,
TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr);
-#endif
-#ifndef TclCreateProc_TCL_DECLARED
-#define TclCreateProc_TCL_DECLARED
/* 10 */
EXTERN int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
- CONST char *procName, Tcl_Obj *argsPtr,
+ const char *procName, Tcl_Obj *argsPtr,
Tcl_Obj *bodyPtr, Proc **procPtrPtr);
-#endif
-#ifndef TclDeleteCompiledLocalVars_TCL_DECLARED
-#define TclDeleteCompiledLocalVars_TCL_DECLARED
/* 11 */
EXTERN void TclDeleteCompiledLocalVars(Interp *iPtr,
CallFrame *framePtr);
-#endif
-#ifndef TclDeleteVars_TCL_DECLARED
-#define TclDeleteVars_TCL_DECLARED
/* 12 */
EXTERN void TclDeleteVars(Interp *iPtr,
TclVarHashTable *tablePtr);
-#endif
/* Slot 13 is reserved */
-#ifndef TclDumpMemoryInfo_TCL_DECLARED
-#define TclDumpMemoryInfo_TCL_DECLARED
/* 14 */
EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags);
-#endif
/* Slot 15 is reserved */
-#ifndef TclExprFloatError_TCL_DECLARED
-#define TclExprFloatError_TCL_DECLARED
/* 16 */
EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
-#endif
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
-#ifndef TclFindElement_TCL_DECLARED
-#define TclFindElement_TCL_DECLARED
/* 22 */
EXTERN int TclFindElement(Tcl_Interp *interp,
- CONST char *listStr, int listLength,
- CONST char **elementPtr,
- CONST char **nextPtr, int *sizePtr,
+ const char *listStr, int listLength,
+ const char **elementPtr,
+ const char **nextPtr, int *sizePtr,
int *bracePtr);
-#endif
-#ifndef TclFindProc_TCL_DECLARED
-#define TclFindProc_TCL_DECLARED
/* 23 */
-EXTERN Proc * TclFindProc(Interp *iPtr, CONST char *procName);
-#endif
-#ifndef TclFormatInt_TCL_DECLARED
-#define TclFormatInt_TCL_DECLARED
+EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
EXTERN int TclFormatInt(char *buffer, long n);
-#endif
-#ifndef TclFreePackageInfo_TCL_DECLARED
-#define TclFreePackageInfo_TCL_DECLARED
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
-#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */
-#ifndef TclpGetDefaultStdChannel_TCL_DECLARED
-#define TclpGetDefaultStdChannel_TCL_DECLARED
/* 28 */
EXTERN Tcl_Channel TclpGetDefaultStdChannel(int type);
-#endif
/* Slot 29 is reserved */
/* Slot 30 is reserved */
-#ifndef TclGetExtension_TCL_DECLARED
-#define TclGetExtension_TCL_DECLARED
/* 31 */
-EXTERN CONST char * TclGetExtension(CONST char *name);
-#endif
-#ifndef TclGetFrame_TCL_DECLARED
-#define TclGetFrame_TCL_DECLARED
+EXTERN const char * TclGetExtension(const char *name);
/* 32 */
-EXTERN int TclGetFrame(Tcl_Interp *interp, CONST char *str,
+EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr);
-#endif
/* Slot 33 is reserved */
-#ifndef TclGetIntForIndex_TCL_DECLARED
-#define TclGetIntForIndex_TCL_DECLARED
/* 34 */
EXTERN int TclGetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr);
-#endif
/* Slot 35 is reserved */
-#ifndef TclGetLong_TCL_DECLARED
-#define TclGetLong_TCL_DECLARED
-/* 36 */
-EXTERN int TclGetLong(Tcl_Interp *interp, CONST char *str,
- long *longPtr);
-#endif
-#ifndef TclGetLoadedPackages_TCL_DECLARED
-#define TclGetLoadedPackages_TCL_DECLARED
+/* Slot 36 is reserved */
/* 37 */
EXTERN int TclGetLoadedPackages(Tcl_Interp *interp,
- char *targetName);
-#endif
-#ifndef TclGetNamespaceForQualName_TCL_DECLARED
-#define TclGetNamespaceForQualName_TCL_DECLARED
+ const char *targetName);
/* 38 */
EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp,
- CONST char *qualName, Namespace *cxtNsPtr,
+ const char *qualName, Namespace *cxtNsPtr,
int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr,
Namespace **actualCxtPtrPtr,
- CONST char **simpleNamePtr);
-#endif
-#ifndef TclGetObjInterpProc_TCL_DECLARED
-#define TclGetObjInterpProc_TCL_DECLARED
+ const char **simpleNamePtr);
/* 39 */
EXTERN TclObjCmdProcType TclGetObjInterpProc(void);
-#endif
-#ifndef TclGetOpenMode_TCL_DECLARED
-#define TclGetOpenMode_TCL_DECLARED
/* 40 */
-EXTERN int TclGetOpenMode(Tcl_Interp *interp, CONST char *str,
+EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str,
int *seekFlagPtr);
-#endif
-#ifndef TclGetOriginalCommand_TCL_DECLARED
-#define TclGetOriginalCommand_TCL_DECLARED
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command);
-#endif
-#ifndef TclpGetUserHome_TCL_DECLARED
-#define TclpGetUserHome_TCL_DECLARED
/* 42 */
-EXTERN char * TclpGetUserHome(CONST char *name,
+EXTERN CONST86 char * TclpGetUserHome(const char *name,
Tcl_DString *bufferPtr);
-#endif
/* Slot 43 is reserved */
-#ifndef TclGuessPackageName_TCL_DECLARED
-#define TclGuessPackageName_TCL_DECLARED
/* 44 */
-EXTERN int TclGuessPackageName(CONST char *fileName,
+EXTERN int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
-#endif
-#ifndef TclHideUnsafeCommands_TCL_DECLARED
-#define TclHideUnsafeCommands_TCL_DECLARED
/* 45 */
EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp);
-#endif
-#ifndef TclInExit_TCL_DECLARED
-#define TclInExit_TCL_DECLARED
/* 46 */
EXTERN int TclInExit(void);
-#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
/* Slot 49 is reserved */
-#ifndef TclInitCompiledLocals_TCL_DECLARED
-#define TclInitCompiledLocals_TCL_DECLARED
/* 50 */
EXTERN void TclInitCompiledLocals(Tcl_Interp *interp,
CallFrame *framePtr, Namespace *nsPtr);
-#endif
-#ifndef TclInterpInit_TCL_DECLARED
-#define TclInterpInit_TCL_DECLARED
/* 51 */
EXTERN int TclInterpInit(Tcl_Interp *interp);
-#endif
/* Slot 52 is reserved */
-#ifndef TclInvokeObjectCommand_TCL_DECLARED
-#define TclInvokeObjectCommand_TCL_DECLARED
/* 53 */
EXTERN int TclInvokeObjectCommand(ClientData clientData,
Tcl_Interp *interp, int argc,
CONST84 char **argv);
-#endif
-#ifndef TclInvokeStringCommand_TCL_DECLARED
-#define TclInvokeStringCommand_TCL_DECLARED
/* 54 */
EXTERN int TclInvokeStringCommand(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef TclIsProc_TCL_DECLARED
-#define TclIsProc_TCL_DECLARED
+ Tcl_Obj *const objv[]);
/* 55 */
EXTERN Proc * TclIsProc(Command *cmdPtr);
-#endif
/* Slot 56 is reserved */
/* Slot 57 is reserved */
-#ifndef TclLookupVar_TCL_DECLARED
-#define TclLookupVar_TCL_DECLARED
/* 58 */
-EXTERN Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, int flags,
- CONST char *msg, int createPart1,
+EXTERN Var * TclLookupVar(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags,
+ const char *msg, int createPart1,
int createPart2, Var **arrayPtrPtr);
-#endif
/* Slot 59 is reserved */
-#ifndef TclNeedSpace_TCL_DECLARED
-#define TclNeedSpace_TCL_DECLARED
/* 60 */
-EXTERN int TclNeedSpace(CONST char *start, CONST char *end);
-#endif
-#ifndef TclNewProcBodyObj_TCL_DECLARED
-#define TclNewProcBodyObj_TCL_DECLARED
+EXTERN int TclNeedSpace(const char *start, const char *end);
/* 61 */
EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr);
-#endif
-#ifndef TclObjCommandComplete_TCL_DECLARED
-#define TclObjCommandComplete_TCL_DECLARED
/* 62 */
EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr);
-#endif
-#ifndef TclObjInterpProc_TCL_DECLARED
-#define TclObjInterpProc_TCL_DECLARED
/* 63 */
EXTERN int TclObjInterpProc(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
-#endif
-#ifndef TclObjInvoke_TCL_DECLARED
-#define TclObjInvoke_TCL_DECLARED
+ Tcl_Obj *const objv[]);
/* 64 */
EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], int flags);
-#endif
+ Tcl_Obj *const objv[], int flags);
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* Slot 67 is reserved */
/* Slot 68 is reserved */
-#ifndef TclpAlloc_TCL_DECLARED
-#define TclpAlloc_TCL_DECLARED
/* 69 */
EXTERN char * TclpAlloc(unsigned int size);
-#endif
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
-#ifndef TclpFree_TCL_DECLARED
-#define TclpFree_TCL_DECLARED
/* 74 */
EXTERN void TclpFree(char *ptr);
-#endif
-#ifndef TclpGetClicks_TCL_DECLARED
-#define TclpGetClicks_TCL_DECLARED
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
-#endif
-#ifndef TclpGetSeconds_TCL_DECLARED
-#define TclpGetSeconds_TCL_DECLARED
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
-#endif
-#ifndef TclpGetTime_TCL_DECLARED
-#define TclpGetTime_TCL_DECLARED
/* 77 */
EXTERN void TclpGetTime(Tcl_Time *time);
-#endif
-#ifndef TclpGetTimeZone_TCL_DECLARED
-#define TclpGetTimeZone_TCL_DECLARED
/* 78 */
EXTERN int TclpGetTimeZone(unsigned long time);
-#endif
/* Slot 79 is reserved */
/* Slot 80 is reserved */
-#ifndef TclpRealloc_TCL_DECLARED
-#define TclpRealloc_TCL_DECLARED
/* 81 */
EXTERN char * TclpRealloc(char *ptr, unsigned int size);
-#endif
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
-#ifndef TclPrecTraceProc_TCL_DECLARED
-#define TclPrecTraceProc_TCL_DECLARED
/* 88 */
EXTERN char * TclPrecTraceProc(ClientData clientData,
- Tcl_Interp *interp, CONST char *name1,
- CONST char *name2, int flags);
-#endif
-#ifndef TclPreventAliasLoop_TCL_DECLARED
-#define TclPreventAliasLoop_TCL_DECLARED
+ Tcl_Interp *interp, const char *name1,
+ const char *name2, int flags);
/* 89 */
EXTERN int TclPreventAliasLoop(Tcl_Interp *interp,
Tcl_Interp *cmdInterp, Tcl_Command cmd);
-#endif
/* Slot 90 is reserved */
-#ifndef TclProcCleanupProc_TCL_DECLARED
-#define TclProcCleanupProc_TCL_DECLARED
/* 91 */
EXTERN void TclProcCleanupProc(Proc *procPtr);
-#endif
-#ifndef TclProcCompileProc_TCL_DECLARED
-#define TclProcCompileProc_TCL_DECLARED
/* 92 */
EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
- CONST char *description,
- CONST char *procName);
-#endif
-#ifndef TclProcDeleteProc_TCL_DECLARED
-#define TclProcDeleteProc_TCL_DECLARED
+ const char *description,
+ const char *procName);
/* 93 */
EXTERN void TclProcDeleteProc(ClientData clientData);
-#endif
/* Slot 94 is reserved */
/* Slot 95 is reserved */
-#ifndef TclRenameCommand_TCL_DECLARED
-#define TclRenameCommand_TCL_DECLARED
/* 96 */
EXTERN int TclRenameCommand(Tcl_Interp *interp,
- CONST char *oldName, CONST char *newName);
-#endif
-#ifndef TclResetShadowedCmdRefs_TCL_DECLARED
-#define TclResetShadowedCmdRefs_TCL_DECLARED
+ const char *oldName, const char *newName);
/* 97 */
EXTERN void TclResetShadowedCmdRefs(Tcl_Interp *interp,
Command *newCmdPtr);
-#endif
-#ifndef TclServiceIdle_TCL_DECLARED
-#define TclServiceIdle_TCL_DECLARED
/* 98 */
EXTERN int TclServiceIdle(void);
-#endif
/* Slot 99 is reserved */
/* Slot 100 is reserved */
-#ifndef TclSetPreInitScript_TCL_DECLARED
-#define TclSetPreInitScript_TCL_DECLARED
/* 101 */
-EXTERN char * TclSetPreInitScript(char *string);
-#endif
-#ifndef TclSetupEnv_TCL_DECLARED
-#define TclSetupEnv_TCL_DECLARED
+EXTERN CONST86 char * TclSetPreInitScript(const char *string);
/* 102 */
EXTERN void TclSetupEnv(Tcl_Interp *interp);
-#endif
-#ifndef TclSockGetPort_TCL_DECLARED
-#define TclSockGetPort_TCL_DECLARED
/* 103 */
-EXTERN int TclSockGetPort(Tcl_Interp *interp, CONST char *str,
- CONST char *proto, int *portPtr);
-#endif
-#ifndef TclSockMinimumBuffers_TCL_DECLARED
-#define TclSockMinimumBuffers_TCL_DECLARED
+EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
+ const char *proto, int *portPtr);
/* 104 */
-EXTERN int TclSockMinimumBuffers(int sock, int size);
-#endif
+EXTERN int TclSockMinimumBuffers(ClientData sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
-#ifndef TclTeardownNamespace_TCL_DECLARED
-#define TclTeardownNamespace_TCL_DECLARED
/* 108 */
EXTERN void TclTeardownNamespace(Namespace *nsPtr);
-#endif
-#ifndef TclUpdateReturnInfo_TCL_DECLARED
-#define TclUpdateReturnInfo_TCL_DECLARED
/* 109 */
EXTERN int TclUpdateReturnInfo(Interp *iPtr);
-#endif
/* Slot 110 is reserved */
-#ifndef Tcl_AddInterpResolvers_TCL_DECLARED
-#define Tcl_AddInterpResolvers_TCL_DECLARED
/* 111 */
EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
-#endif
-#ifndef Tcl_AppendExportList_TCL_DECLARED
-#define Tcl_AppendExportList_TCL_DECLARED
/* 112 */
EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_CreateNamespace_TCL_DECLARED
-#define Tcl_CreateNamespace_TCL_DECLARED
/* 113 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- CONST char *name, ClientData clientData,
+ const char *name, ClientData clientData,
Tcl_NamespaceDeleteProc *deleteProc);
-#endif
-#ifndef Tcl_DeleteNamespace_TCL_DECLARED
-#define Tcl_DeleteNamespace_TCL_DECLARED
/* 114 */
EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
-#endif
-#ifndef Tcl_Export_TCL_DECLARED
-#define Tcl_Export_TCL_DECLARED
/* 115 */
EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int resetListFirst);
-#endif
-#ifndef Tcl_FindCommand_TCL_DECLARED
-#define Tcl_FindCommand_TCL_DECLARED
+ const char *pattern, int resetListFirst);
/* 116 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name,
+EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-#endif
-#ifndef Tcl_FindNamespace_TCL_DECLARED
-#define Tcl_FindNamespace_TCL_DECLARED
/* 117 */
EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-#endif
-#ifndef Tcl_GetInterpResolvers_TCL_DECLARED
-#define Tcl_GetInterpResolvers_TCL_DECLARED
/* 118 */
EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp,
- CONST char *name, Tcl_ResolverInfo *resInfo);
-#endif
-#ifndef Tcl_GetNamespaceResolvers_TCL_DECLARED
-#define Tcl_GetNamespaceResolvers_TCL_DECLARED
+ const char *name, Tcl_ResolverInfo *resInfo);
/* 119 */
EXTERN int Tcl_GetNamespaceResolvers(
Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo);
-#endif
-#ifndef Tcl_FindNamespaceVar_TCL_DECLARED
-#define Tcl_FindNamespaceVar_TCL_DECLARED
/* 120 */
EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
- CONST char *name,
+ const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-#endif
-#ifndef Tcl_ForgetImport_TCL_DECLARED
-#define Tcl_ForgetImport_TCL_DECLARED
/* 121 */
EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
- Tcl_Namespace *nsPtr, CONST char *pattern);
-#endif
-#ifndef Tcl_GetCommandFromObj_TCL_DECLARED
-#define Tcl_GetCommandFromObj_TCL_DECLARED
+ Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetCommandFullName_TCL_DECLARED
-#define Tcl_GetCommandFullName_TCL_DECLARED
/* 123 */
EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_GetCurrentNamespace_TCL_DECLARED
-#define Tcl_GetCurrentNamespace_TCL_DECLARED
/* 124 */
EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetGlobalNamespace_TCL_DECLARED
-#define Tcl_GetGlobalNamespace_TCL_DECLARED
/* 125 */
EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_GetVariableFullName_TCL_DECLARED
-#define Tcl_GetVariableFullName_TCL_DECLARED
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
-#endif
-#ifndef Tcl_Import_TCL_DECLARED
-#define Tcl_Import_TCL_DECLARED
/* 127 */
EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *pattern, int allowOverwrite);
-#endif
-#ifndef Tcl_PopCallFrame_TCL_DECLARED
-#define Tcl_PopCallFrame_TCL_DECLARED
+ const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
-#endif
-#ifndef Tcl_PushCallFrame_TCL_DECLARED
-#define Tcl_PushCallFrame_TCL_DECLARED
/* 129 */
EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp,
Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame);
-#endif
-#ifndef Tcl_RemoveInterpResolvers_TCL_DECLARED
-#define Tcl_RemoveInterpResolvers_TCL_DECLARED
/* 130 */
EXTERN int Tcl_RemoveInterpResolvers(Tcl_Interp *interp,
- CONST char *name);
-#endif
-#ifndef Tcl_SetNamespaceResolvers_TCL_DECLARED
-#define Tcl_SetNamespaceResolvers_TCL_DECLARED
+ const char *name);
/* 131 */
EXTERN void Tcl_SetNamespaceResolvers(
Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
-#endif
-#ifndef TclpHasSockets_TCL_DECLARED
-#define TclpHasSockets_TCL_DECLARED
/* 132 */
EXTERN int TclpHasSockets(Tcl_Interp *interp);
-#endif
-#ifndef TclpGetDate_TCL_DECLARED
-#define TclpGetDate_TCL_DECLARED
/* 133 */
-EXTERN struct tm * TclpGetDate(CONST time_t *time, int useGMT);
-#endif
+EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
-#ifndef TclGetEnv_TCL_DECLARED
-#define TclGetEnv_TCL_DECLARED
/* 138 */
-EXTERN CONST84_RETURN char * TclGetEnv(CONST char *name,
+EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
Tcl_DString *valuePtr);
-#endif
/* Slot 139 is reserved */
/* Slot 140 is reserved */
-#ifndef TclpGetCwd_TCL_DECLARED
-#define TclpGetCwd_TCL_DECLARED
/* 141 */
EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
Tcl_DString *cwdPtr);
-#endif
-#ifndef TclSetByteCodeFromAny_TCL_DECLARED
-#define TclSetByteCodeFromAny_TCL_DECLARED
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
ClientData clientData);
-#endif
-#ifndef TclAddLiteralObj_TCL_DECLARED
-#define TclAddLiteralObj_TCL_DECLARED
/* 143 */
EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr,
Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
-#endif
-#ifndef TclHideLiteral_TCL_DECLARED
-#define TclHideLiteral_TCL_DECLARED
/* 144 */
EXTERN void TclHideLiteral(Tcl_Interp *interp,
struct CompileEnv *envPtr, int index);
-#endif
-#ifndef TclGetAuxDataType_TCL_DECLARED
-#define TclGetAuxDataType_TCL_DECLARED
/* 145 */
-EXTERN struct AuxDataType * TclGetAuxDataType(char *typeName);
-#endif
-#ifndef TclHandleCreate_TCL_DECLARED
-#define TclHandleCreate_TCL_DECLARED
+EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName);
/* 146 */
-EXTERN TclHandle TclHandleCreate(VOID *ptr);
-#endif
-#ifndef TclHandleFree_TCL_DECLARED
-#define TclHandleFree_TCL_DECLARED
+EXTERN TclHandle TclHandleCreate(void *ptr);
/* 147 */
EXTERN void TclHandleFree(TclHandle handle);
-#endif
-#ifndef TclHandlePreserve_TCL_DECLARED
-#define TclHandlePreserve_TCL_DECLARED
/* 148 */
EXTERN TclHandle TclHandlePreserve(TclHandle handle);
-#endif
-#ifndef TclHandleRelease_TCL_DECLARED
-#define TclHandleRelease_TCL_DECLARED
/* 149 */
EXTERN void TclHandleRelease(TclHandle handle);
-#endif
-#ifndef TclRegAbout_TCL_DECLARED
-#define TclRegAbout_TCL_DECLARED
/* 150 */
EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re);
-#endif
-#ifndef TclRegExpRangeUniChar_TCL_DECLARED
-#define TclRegExpRangeUniChar_TCL_DECLARED
/* 151 */
EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, int index,
int *startPtr, int *endPtr);
-#endif
-#ifndef TclSetLibraryPath_TCL_DECLARED
-#define TclSetLibraryPath_TCL_DECLARED
/* 152 */
EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr);
-#endif
-#ifndef TclGetLibraryPath_TCL_DECLARED
-#define TclGetLibraryPath_TCL_DECLARED
/* 153 */
EXTERN Tcl_Obj * TclGetLibraryPath(void);
-#endif
/* Slot 154 is reserved */
/* Slot 155 is reserved */
-#ifndef TclRegError_TCL_DECLARED
-#define TclRegError_TCL_DECLARED
/* 156 */
-EXTERN void TclRegError(Tcl_Interp *interp, CONST char *msg,
+EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
int status);
-#endif
-#ifndef TclVarTraceExists_TCL_DECLARED
-#define TclVarTraceExists_TCL_DECLARED
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
- CONST char *varName);
-#endif
-#ifndef TclSetStartupScriptFileName_TCL_DECLARED
-#define TclSetStartupScriptFileName_TCL_DECLARED
-/* 158 */
-EXTERN void TclSetStartupScriptFileName(CONST char *filename);
-#endif
-#ifndef TclGetStartupScriptFileName_TCL_DECLARED
-#define TclGetStartupScriptFileName_TCL_DECLARED
-/* 159 */
-EXTERN CONST84_RETURN char * TclGetStartupScriptFileName(void);
-#endif
+ const char *varName);
+/* Slot 158 is reserved */
+/* Slot 159 is reserved */
/* Slot 160 is reserved */
-#ifndef TclChannelTransform_TCL_DECLARED
-#define TclChannelTransform_TCL_DECLARED
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
-#endif
-#ifndef TclChannelEventScriptInvoker_TCL_DECLARED
-#define TclChannelEventScriptInvoker_TCL_DECLARED
/* 162 */
EXTERN void TclChannelEventScriptInvoker(ClientData clientData,
int flags);
-#endif
-#ifndef TclGetInstructionTable_TCL_DECLARED
-#define TclGetInstructionTable_TCL_DECLARED
/* 163 */
-EXTERN VOID * TclGetInstructionTable(void);
-#endif
-#ifndef TclExpandCodeArray_TCL_DECLARED
-#define TclExpandCodeArray_TCL_DECLARED
+EXTERN const void * TclGetInstructionTable(void);
/* 164 */
-EXTERN void TclExpandCodeArray(VOID *envPtr);
-#endif
-#ifndef TclpSetInitialEncodings_TCL_DECLARED
-#define TclpSetInitialEncodings_TCL_DECLARED
+EXTERN void TclExpandCodeArray(void *envPtr);
/* 165 */
EXTERN void TclpSetInitialEncodings(void);
-#endif
-#ifndef TclListObjSetElement_TCL_DECLARED
-#define TclListObjSetElement_TCL_DECLARED
/* 166 */
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
-#endif
-#ifndef TclSetStartupScriptPath_TCL_DECLARED
-#define TclSetStartupScriptPath_TCL_DECLARED
-/* 167 */
-EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
-#endif
-#ifndef TclGetStartupScriptPath_TCL_DECLARED
-#define TclGetStartupScriptPath_TCL_DECLARED
-/* 168 */
-EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
-#endif
-#ifndef TclpUtfNcmp2_TCL_DECLARED
-#define TclpUtfNcmp2_TCL_DECLARED
+/* Slot 167 is reserved */
+/* Slot 168 is reserved */
/* 169 */
-EXTERN int TclpUtfNcmp2(CONST char *s1, CONST char *s2,
+EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
-#endif
-#ifndef TclCheckInterpTraces_TCL_DECLARED
-#define TclCheckInterpTraces_TCL_DECLARED
/* 170 */
EXTERN int TclCheckInterpTraces(Tcl_Interp *interp,
- CONST char *command, int numChars,
+ const char *command, int numChars,
Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef TclCheckExecutionTraces_TCL_DECLARED
-#define TclCheckExecutionTraces_TCL_DECLARED
+ int objc, Tcl_Obj *const objv[]);
/* 171 */
EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp,
- CONST char *command, int numChars,
+ const char *command, int numChars,
Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *CONST objv[]);
-#endif
-#ifndef TclInThreadExit_TCL_DECLARED
-#define TclInThreadExit_TCL_DECLARED
+ int objc, Tcl_Obj *const objv[]);
/* 172 */
EXTERN int TclInThreadExit(void);
-#endif
-#ifndef TclUniCharMatch_TCL_DECLARED
-#define TclUniCharMatch_TCL_DECLARED
/* 173 */
-EXTERN int TclUniCharMatch(CONST Tcl_UniChar *string,
- int strLen, CONST Tcl_UniChar *pattern,
+EXTERN int TclUniCharMatch(const Tcl_UniChar *string,
+ int strLen, const Tcl_UniChar *pattern,
int ptnLen, int flags);
-#endif
/* Slot 174 is reserved */
-#ifndef TclCallVarTraces_TCL_DECLARED
-#define TclCallVarTraces_TCL_DECLARED
/* 175 */
EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr,
- Var *varPtr, CONST char *part1,
- CONST char *part2, int flags,
+ Var *varPtr, const char *part1,
+ const char *part2, int flags,
int leaveErrMsg);
-#endif
-#ifndef TclCleanupVar_TCL_DECLARED
-#define TclCleanupVar_TCL_DECLARED
/* 176 */
EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr);
-#endif
-#ifndef TclVarErrMsg_TCL_DECLARED
-#define TclVarErrMsg_TCL_DECLARED
/* 177 */
-EXTERN void TclVarErrMsg(Tcl_Interp *interp, CONST char *part1,
- CONST char *part2, CONST char *operation,
- CONST char *reason);
-#endif
-#ifndef Tcl_SetStartupScript_TCL_DECLARED
-#define Tcl_SetStartupScript_TCL_DECLARED
-/* 178 */
-EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
- CONST char*encodingName);
-#endif
-#ifndef Tcl_GetStartupScript_TCL_DECLARED
-#define Tcl_GetStartupScript_TCL_DECLARED
-/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(CONST char **encodingNamePtr);
-#endif
+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 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
-#ifndef TclpLocaltime_TCL_DECLARED
-#define TclpLocaltime_TCL_DECLARED
/* 182 */
-EXTERN struct tm * TclpLocaltime(CONST time_t *clock);
-#endif
-#ifndef TclpGmtime_TCL_DECLARED
-#define TclpGmtime_TCL_DECLARED
+EXTERN struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
-EXTERN struct tm * TclpGmtime(CONST time_t *clock);
-#endif
+EXTERN struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
@@ -844,363 +469,290 @@ EXTERN struct tm * TclpGmtime(CONST time_t *clock);
/* Slot 195 is reserved */
/* Slot 196 is reserved */
/* Slot 197 is reserved */
-#ifndef TclObjGetFrame_TCL_DECLARED
-#define TclObjGetFrame_TCL_DECLARED
/* 198 */
EXTERN int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr);
-#endif
/* Slot 199 is reserved */
-#ifndef TclpObjRemoveDirectory_TCL_DECLARED
-#define TclpObjRemoveDirectory_TCL_DECLARED
/* 200 */
EXTERN int TclpObjRemoveDirectory(Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr);
-#endif
-#ifndef TclpObjCopyDirectory_TCL_DECLARED
-#define TclpObjCopyDirectory_TCL_DECLARED
/* 201 */
EXTERN int TclpObjCopyDirectory(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr);
-#endif
-#ifndef TclpObjCreateDirectory_TCL_DECLARED
-#define TclpObjCreateDirectory_TCL_DECLARED
/* 202 */
EXTERN int TclpObjCreateDirectory(Tcl_Obj *pathPtr);
-#endif
-#ifndef TclpObjDeleteFile_TCL_DECLARED
-#define TclpObjDeleteFile_TCL_DECLARED
/* 203 */
EXTERN int TclpObjDeleteFile(Tcl_Obj *pathPtr);
-#endif
-#ifndef TclpObjCopyFile_TCL_DECLARED
-#define TclpObjCopyFile_TCL_DECLARED
/* 204 */
EXTERN int TclpObjCopyFile(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr);
-#endif
-#ifndef TclpObjRenameFile_TCL_DECLARED
-#define TclpObjRenameFile_TCL_DECLARED
/* 205 */
EXTERN int TclpObjRenameFile(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr);
-#endif
-#ifndef TclpObjStat_TCL_DECLARED
-#define TclpObjStat_TCL_DECLARED
/* 206 */
EXTERN int TclpObjStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
-#endif
-#ifndef TclpObjAccess_TCL_DECLARED
-#define TclpObjAccess_TCL_DECLARED
/* 207 */
EXTERN int TclpObjAccess(Tcl_Obj *pathPtr, int mode);
-#endif
-#ifndef TclpOpenFileChannel_TCL_DECLARED
-#define TclpOpenFileChannel_TCL_DECLARED
/* 208 */
EXTERN Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp,
Tcl_Obj *pathPtr, int mode, int permissions);
-#endif
/* Slot 209 is reserved */
/* Slot 210 is reserved */
/* Slot 211 is reserved */
-#ifndef TclpFindExecutable_TCL_DECLARED
-#define TclpFindExecutable_TCL_DECLARED
/* 212 */
-EXTERN void TclpFindExecutable(CONST char *argv0);
-#endif
-#ifndef TclGetObjNameOfExecutable_TCL_DECLARED
-#define TclGetObjNameOfExecutable_TCL_DECLARED
+EXTERN void TclpFindExecutable(const char *argv0);
/* 213 */
EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void);
-#endif
-#ifndef TclSetObjNameOfExecutable_TCL_DECLARED
-#define TclSetObjNameOfExecutable_TCL_DECLARED
/* 214 */
EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name,
Tcl_Encoding encoding);
-#endif
-#ifndef TclStackAlloc_TCL_DECLARED
-#define TclStackAlloc_TCL_DECLARED
/* 215 */
-EXTERN VOID * TclStackAlloc(Tcl_Interp *interp, int numBytes);
-#endif
-#ifndef TclStackFree_TCL_DECLARED
-#define TclStackFree_TCL_DECLARED
+EXTERN void * TclStackAlloc(Tcl_Interp *interp, int numBytes);
/* 216 */
-EXTERN void TclStackFree(Tcl_Interp *interp, VOID *freePtr);
-#endif
-#ifndef TclPushStackFrame_TCL_DECLARED
-#define TclPushStackFrame_TCL_DECLARED
+EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr);
/* 217 */
EXTERN int TclPushStackFrame(Tcl_Interp *interp,
Tcl_CallFrame **framePtrPtr,
Tcl_Namespace *namespacePtr,
int isProcCallFrame);
-#endif
-#ifndef TclPopStackFrame_TCL_DECLARED
-#define TclPopStackFrame_TCL_DECLARED
/* 218 */
EXTERN void TclPopStackFrame(Tcl_Interp *interp);
-#endif
/* Slot 219 is reserved */
/* Slot 220 is reserved */
/* Slot 221 is reserved */
/* Slot 222 is reserved */
/* Slot 223 is reserved */
-#ifndef TclGetPlatform_TCL_DECLARED
-#define TclGetPlatform_TCL_DECLARED
/* 224 */
EXTERN TclPlatformType * TclGetPlatform(void);
-#endif
-#ifndef TclTraceDictPath_TCL_DECLARED
-#define TclTraceDictPath_TCL_DECLARED
/* 225 */
EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp,
Tcl_Obj *rootPtr, int keyc,
- Tcl_Obj *CONST keyv[], int flags);
-#endif
-#ifndef TclObjBeingDeleted_TCL_DECLARED
-#define TclObjBeingDeleted_TCL_DECLARED
+ Tcl_Obj *const keyv[], int flags);
/* 226 */
EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr);
-#endif
-#ifndef TclSetNsPath_TCL_DECLARED
-#define TclSetNsPath_TCL_DECLARED
/* 227 */
EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[]);
-#endif
-#ifndef TclObjInterpProcCore_TCL_DECLARED
-#define TclObjInterpProcCore_TCL_DECLARED
-/* 228 */
-EXTERN int TclObjInterpProcCore(register Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int skip,
- ProcErrorProc errorProc);
-#endif
-#ifndef TclPtrMakeUpvar_TCL_DECLARED
-#define TclPtrMakeUpvar_TCL_DECLARED
+/* Slot 228 is reserved */
/* 229 */
EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
- CONST char *myName, int myFlags, int index);
-#endif
-#ifndef TclObjLookupVar_TCL_DECLARED
-#define TclObjLookupVar_TCL_DECLARED
+ const char *myName, int myFlags, int index);
/* 230 */
EXTERN Var * TclObjLookupVar(Tcl_Interp *interp,
- Tcl_Obj *part1Ptr, CONST char *part2,
- int flags, CONST char *msg,
- CONST int createPart1, CONST int createPart2,
+ Tcl_Obj *part1Ptr, const char *part2,
+ int flags, const char *msg,
+ const int createPart1, const int createPart2,
Var **arrayPtrPtr);
-#endif
-#ifndef TclGetNamespaceFromObj_TCL_DECLARED
-#define TclGetNamespaceFromObj_TCL_DECLARED
/* 231 */
EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
-#endif
-#ifndef TclEvalObjEx_TCL_DECLARED
-#define TclEvalObjEx_TCL_DECLARED
/* 232 */
EXTERN int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
- int flags, CONST CmdFrame *invoker, int word);
-#endif
-#ifndef TclGetSrcInfoForPc_TCL_DECLARED
-#define TclGetSrcInfoForPc_TCL_DECLARED
+ int flags, const CmdFrame *invoker, int word);
/* 233 */
EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr);
-#endif
-#ifndef TclVarHashCreateVar_TCL_DECLARED
-#define TclVarHashCreateVar_TCL_DECLARED
/* 234 */
EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
- CONST char *key, int *newPtr);
-#endif
-#ifndef TclInitVarHashTable_TCL_DECLARED
-#define TclInitVarHashTable_TCL_DECLARED
+ const char *key, int *newPtr);
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
-#endif
-#ifndef TclBackgroundException_TCL_DECLARED
-#define TclBackgroundException_TCL_DECLARED
-/* 236 */
-EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
-#endif
-/* Slot 237 is reserved */
-/* Slot 238 is reserved */
-/* Slot 239 is reserved */
-/* Slot 240 is reserved */
-/* Slot 241 is reserved */
-/* Slot 242 is reserved */
-#ifndef TclDbDumpActiveObjects_TCL_DECLARED
-#define TclDbDumpActiveObjects_TCL_DECLARED
+/* Slot 236 is reserved */
+/* 237 */
+EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
+/* 238 */
+EXTERN int TclNRInterpProc(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+/* 239 */
+EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj, int skip,
+ ProcErrorProc *errorProc);
+/* 240 */
+EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result,
+ struct NRE_callback *rootPtr);
+/* 241 */
+EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags, const CmdFrame *invoker, int word);
+/* 242 */
+EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags,
+ Command *cmdPtr);
/* 243 */
EXTERN void TclDbDumpActiveObjects(FILE *outFile);
-#endif
-/* Slot 244 is reserved */
-/* Slot 245 is reserved */
-/* Slot 246 is reserved */
-/* Slot 247 is reserved */
-/* Slot 248 is reserved */
-#ifndef TclDoubleDigits_TCL_DECLARED
-#define TclDoubleDigits_TCL_DECLARED
+/* 244 */
+EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr);
+/* 245 */
+EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr);
+/* 246 */
+EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp,
+ int numRemoved, int numInserted,
+ Tcl_Obj *const *objv);
+/* 247 */
+EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp,
+ int isRootEnsemble);
+/* 248 */
+EXTERN int TclCopyChannel(Tcl_Interp *interp,
+ Tcl_Channel inChan, Tcl_Channel outChan,
+ Tcl_WideInt toRead, Tcl_Obj *cmdPtr);
/* 249 */
EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags,
int*decpt, int*signum, char**endPtr);
-#endif
+/* 250 */
+EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
+ int force);
typedef struct TclIntStubs {
int magic;
- struct TclIntStubHooks *hooks;
+ const struct TclIntStubHooks *hooks;
- VOID *reserved0;
- VOID *reserved1;
- VOID *reserved2;
+ void (*reserved0)(void);
+ void (*reserved1)(void);
+ void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
- VOID *reserved4;
+ void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
- int (*tclCopyAndCollapse) (int count, CONST char *src, char *dst); /* 7 */
- int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
- int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, CONST char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
- int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
+ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */
+ int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
+ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
+ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
- VOID *reserved13;
+ void (*reserved13)(void);
int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */
- VOID *reserved15;
+ void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
- VOID *reserved17;
- VOID *reserved18;
- VOID *reserved19;
- VOID *reserved20;
- VOID *reserved21;
- int (*tclFindElement) (Tcl_Interp *interp, CONST char *listStr, int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
- Proc * (*tclFindProc) (Interp *iPtr, CONST char *procName); /* 23 */
+ void (*reserved17)(void);
+ void (*reserved18)(void);
+ void (*reserved19)(void);
+ void (*reserved20)(void);
+ void (*reserved21)(void);
+ int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
+ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
int (*tclFormatInt) (char *buffer, long n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
- VOID *reserved26;
- VOID *reserved27;
+ void (*reserved26)(void);
+ void (*reserved27)(void);
Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
- VOID *reserved29;
- VOID *reserved30;
- CONST char * (*tclGetExtension) (CONST char *name); /* 31 */
- int (*tclGetFrame) (Tcl_Interp *interp, CONST char *str, CallFrame **framePtrPtr); /* 32 */
- VOID *reserved33;
+ void (*reserved29)(void);
+ void (*reserved30)(void);
+ const char * (*tclGetExtension) (const char *name); /* 31 */
+ int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
+ void (*reserved33)(void);
int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
- VOID *reserved35;
- int (*tclGetLong) (Tcl_Interp *interp, CONST char *str, long *longPtr); /* 36 */
- int (*tclGetLoadedPackages) (Tcl_Interp *interp, char *targetName); /* 37 */
- int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, CONST char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, CONST char **simpleNamePtr); /* 38 */
+ void (*reserved35)(void);
+ void (*reserved36)(void);
+ int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
+ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
- int (*tclGetOpenMode) (Tcl_Interp *interp, CONST char *str, int *seekFlagPtr); /* 40 */
+ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
- char * (*tclpGetUserHome) (CONST char *name, Tcl_DString *bufferPtr); /* 42 */
- VOID *reserved43;
- int (*tclGuessPackageName) (CONST char *fileName, Tcl_DString *bufPtr); /* 44 */
+ CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
+ void (*reserved43)(void);
+ int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
- VOID *reserved47;
- VOID *reserved48;
- VOID *reserved49;
+ void (*reserved47)(void);
+ void (*reserved48)(void);
+ void (*reserved49)(void);
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
- VOID *reserved52;
+ void (*reserved52)(void);
int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */
- int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 54 */
+ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
- VOID *reserved56;
- VOID *reserved57;
- Var * (*tclLookupVar) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, CONST char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */
- VOID *reserved59;
- int (*tclNeedSpace) (CONST char *start, CONST char *end); /* 60 */
+ void (*reserved56)(void);
+ void (*reserved57)(void);
+ Var * (*tclLookupVar) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */
+ void (*reserved59)(void);
+ int (*tclNeedSpace) (const char *start, const char *end); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
- int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 63 */
- int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 64 */
- VOID *reserved65;
- VOID *reserved66;
- VOID *reserved67;
- VOID *reserved68;
+ int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */
+ int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */
+ void (*reserved65)(void);
+ void (*reserved66)(void);
+ void (*reserved67)(void);
+ void (*reserved68)(void);
char * (*tclpAlloc) (unsigned int size); /* 69 */
- VOID *reserved70;
- VOID *reserved71;
- VOID *reserved72;
- VOID *reserved73;
+ void (*reserved70)(void);
+ void (*reserved71)(void);
+ void (*reserved72)(void);
+ void (*reserved73)(void);
void (*tclpFree) (char *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
void (*tclpGetTime) (Tcl_Time *time); /* 77 */
int (*tclpGetTimeZone) (unsigned long time); /* 78 */
- VOID *reserved79;
- VOID *reserved80;
+ void (*reserved79)(void);
+ void (*reserved80)(void);
char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
- VOID *reserved82;
- VOID *reserved83;
- VOID *reserved84;
- VOID *reserved85;
- VOID *reserved86;
- VOID *reserved87;
- char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); /* 88 */
+ void (*reserved82)(void);
+ void (*reserved83)(void);
+ void (*reserved84)(void);
+ void (*reserved85)(void);
+ void (*reserved86)(void);
+ void (*reserved87)(void);
+ char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */
int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */
- VOID *reserved90;
+ void (*reserved90)(void);
void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */
- int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName); /* 92 */
+ int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */
void (*tclProcDeleteProc) (ClientData clientData); /* 93 */
- VOID *reserved94;
- VOID *reserved95;
- int (*tclRenameCommand) (Tcl_Interp *interp, CONST char *oldName, CONST char *newName); /* 96 */
+ void (*reserved94)(void);
+ void (*reserved95)(void);
+ int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */
int (*tclServiceIdle) (void); /* 98 */
- VOID *reserved99;
- VOID *reserved100;
- char * (*tclSetPreInitScript) (char *string); /* 101 */
+ void (*reserved99)(void);
+ void (*reserved100)(void);
+ CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
- int (*tclSockGetPort) (Tcl_Interp *interp, CONST char *str, CONST char *proto, int *portPtr); /* 103 */
- int (*tclSockMinimumBuffers) (int sock, int size); /* 104 */
- VOID *reserved105;
- VOID *reserved106;
- VOID *reserved107;
+ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
+ int (*tclSockMinimumBuffers) (ClientData sock, int size); /* 104 */
+ void (*reserved105)(void);
+ void (*reserved106)(void);
+ void (*reserved107)(void);
void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
- VOID *reserved110;
- void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, CONST char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
+ void (*reserved110)(void);
+ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int resetListFirst); /* 115 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
- int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, CONST char *name, Tcl_ResolverInfo *resInfo); /* 118 */
+ int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
+ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
- Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern); /* 121 */
+ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
+ int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int allowOverwrite); /* 127 */
+ int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
- int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, CONST char *name); /* 130 */
+ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */
int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
- struct tm * (*tclpGetDate) (CONST time_t *time, int useGMT); /* 133 */
- VOID *reserved134;
- VOID *reserved135;
- VOID *reserved136;
- VOID *reserved137;
- CONST84_RETURN char * (*tclGetEnv) (CONST char *name, Tcl_DString *valuePtr); /* 138 */
- VOID *reserved139;
- VOID *reserved140;
+ struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
+ void (*reserved134)(void);
+ void (*reserved135)(void);
+ void (*reserved136)(void);
+ void (*reserved137)(void);
+ CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
+ void (*reserved139)(void);
+ void (*reserved140)(void);
CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
- struct AuxDataType * (*tclGetAuxDataType) (char *typeName); /* 145 */
- TclHandle (*tclHandleCreate) (VOID *ptr); /* 146 */
+ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
+ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
void (*tclHandleFree) (TclHandle handle); /* 147 */
TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
void (*tclHandleRelease) (TclHandle handle); /* 149 */
@@ -1208,52 +760,52 @@ typedef struct TclIntStubs {
void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */
void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */
Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
- VOID *reserved154;
- VOID *reserved155;
- void (*tclRegError) (Tcl_Interp *interp, CONST char *msg, int status); /* 156 */
- Var * (*tclVarTraceExists) (Tcl_Interp *interp, CONST char *varName); /* 157 */
- void (*tclSetStartupScriptFileName) (CONST char *filename); /* 158 */
- CONST84_RETURN char * (*tclGetStartupScriptFileName) (void); /* 159 */
- VOID *reserved160;
+ void (*reserved154)(void);
+ void (*reserved155)(void);
+ void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
+ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
+ void (*reserved158)(void);
+ void (*reserved159)(void);
+ void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
- VOID * (*tclGetInstructionTable) (void); /* 163 */
- void (*tclExpandCodeArray) (VOID *envPtr); /* 164 */
+ const void * (*tclGetInstructionTable) (void); /* 163 */
+ void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
- 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 */
+ void (*reserved167)(void);
+ void (*reserved168)(void);
+ 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 */
int (*tclInThreadExit) (void); /* 172 */
- int (*tclUniCharMatch) (CONST Tcl_UniChar *string, int strLen, CONST Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
- VOID *reserved174;
- int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, CONST char *part1, CONST char *part2, int flags, int leaveErrMsg); /* 175 */
+ int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
+ void (*reserved174)(void);
+ 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 (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, CONST char*encodingName); /* 178 */
- Tcl_Obj * (*tcl_GetStartupScript) (CONST char **encodingNamePtr); /* 179 */
- VOID *reserved180;
- VOID *reserved181;
- struct tm * (*tclpLocaltime) (CONST time_t *clock); /* 182 */
- struct tm * (*tclpGmtime) (CONST time_t *clock); /* 183 */
- VOID *reserved184;
- VOID *reserved185;
- VOID *reserved186;
- VOID *reserved187;
- VOID *reserved188;
- VOID *reserved189;
- VOID *reserved190;
- VOID *reserved191;
- VOID *reserved192;
- VOID *reserved193;
- VOID *reserved194;
- VOID *reserved195;
- VOID *reserved196;
- VOID *reserved197;
+ 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 (*reserved180)(void);
+ void (*reserved181)(void);
+ struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
+ struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
+ void (*reserved184)(void);
+ void (*reserved185)(void);
+ void (*reserved186)(void);
+ void (*reserved187)(void);
+ void (*reserved188)(void);
+ void (*reserved189)(void);
+ void (*reserved190)(void);
+ void (*reserved191)(void);
+ void (*reserved192)(void);
+ void (*reserved193)(void);
+ void (*reserved194)(void);
+ void (*reserved195)(void);
+ void (*reserved196)(void);
+ void (*reserved197)(void);
int (*tclObjGetFrame) (Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr); /* 198 */
- VOID *reserved199;
+ void (*reserved199)(void);
int (*tclpObjRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 200 */
int (*tclpObjCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 201 */
int (*tclpObjCreateDirectory) (Tcl_Obj *pathPtr); /* 202 */
@@ -1263,58 +815,59 @@ typedef struct TclIntStubs {
int (*tclpObjStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 206 */
int (*tclpObjAccess) (Tcl_Obj *pathPtr, int mode); /* 207 */
Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */
- VOID *reserved209;
- VOID *reserved210;
- VOID *reserved211;
- void (*tclpFindExecutable) (CONST char *argv0); /* 212 */
+ void (*reserved209)(void);
+ void (*reserved210)(void);
+ void (*reserved211)(void);
+ void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
- VOID * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */
- void (*tclStackFree) (Tcl_Interp *interp, VOID *freePtr); /* 216 */
+ void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */
+ void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
- VOID *reserved219;
- VOID *reserved220;
- VOID *reserved221;
- VOID *reserved222;
- VOID *reserved223;
+ void (*reserved219)(void);
+ void (*reserved220)(void);
+ void (*reserved221)(void);
+ void (*reserved222)(void);
+ void (*reserved223)(void);
TclPlatformType * (*tclGetPlatform) (void); /* 224 */
- Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags); /* 225 */
+ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */
- int (*tclObjInterpProcCore) (register Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc errorProc); /* 228 */
- int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, CONST char *myName, int myFlags, int index); /* 229 */
- Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, CONST char *part2, int flags, CONST char *msg, CONST int createPart1, CONST int createPart2, Var **arrayPtrPtr); /* 230 */
+ void (*reserved228)(void);
+ int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
+ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
- int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, CONST CmdFrame *invoker, int word); /* 232 */
+ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
- Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, CONST char *key, int *newPtr); /* 234 */
+ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
- VOID *reserved237;
- VOID *reserved238;
- VOID *reserved239;
- VOID *reserved240;
- VOID *reserved241;
- VOID *reserved242;
+ void (*reserved236)(void);
+ 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 */
+ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
+ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
+ int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
- VOID *reserved244;
- VOID *reserved245;
- VOID *reserved246;
- VOID *reserved247;
- VOID *reserved248;
+ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
+ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
+ int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */
+ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
+ 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 */
} TclIntStubs;
#ifdef __cplusplus
extern "C" {
#endif
-extern TclIntStubs *tclIntStubsPtr;
+extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
-#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
@@ -1323,553 +876,302 @@ extern TclIntStubs *tclIntStubsPtr;
/* Slot 0 is reserved */
/* Slot 1 is reserved */
/* Slot 2 is reserved */
-#ifndef TclAllocateFreeObjects
#define TclAllocateFreeObjects \
(tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
-#endif
/* Slot 4 is reserved */
-#ifndef TclCleanupChildren
#define TclCleanupChildren \
(tclIntStubsPtr->tclCleanupChildren) /* 5 */
-#endif
-#ifndef TclCleanupCommand
#define TclCleanupCommand \
(tclIntStubsPtr->tclCleanupCommand) /* 6 */
-#endif
-#ifndef TclCopyAndCollapse
#define TclCopyAndCollapse \
(tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
-#endif
-#ifndef TclCopyChannel
-#define TclCopyChannel \
- (tclIntStubsPtr->tclCopyChannel) /* 8 */
-#endif
-#ifndef TclCreatePipeline
+#define TclCopyChannelOld \
+ (tclIntStubsPtr->tclCopyChannelOld) /* 8 */
#define TclCreatePipeline \
(tclIntStubsPtr->tclCreatePipeline) /* 9 */
-#endif
-#ifndef TclCreateProc
#define TclCreateProc \
(tclIntStubsPtr->tclCreateProc) /* 10 */
-#endif
-#ifndef TclDeleteCompiledLocalVars
#define TclDeleteCompiledLocalVars \
(tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */
-#endif
-#ifndef TclDeleteVars
#define TclDeleteVars \
(tclIntStubsPtr->tclDeleteVars) /* 12 */
-#endif
/* Slot 13 is reserved */
-#ifndef TclDumpMemoryInfo
#define TclDumpMemoryInfo \
(tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */
-#endif
/* Slot 15 is reserved */
-#ifndef TclExprFloatError
#define TclExprFloatError \
(tclIntStubsPtr->tclExprFloatError) /* 16 */
-#endif
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
-#ifndef TclFindElement
#define TclFindElement \
(tclIntStubsPtr->tclFindElement) /* 22 */
-#endif
-#ifndef TclFindProc
#define TclFindProc \
(tclIntStubsPtr->tclFindProc) /* 23 */
-#endif
-#ifndef TclFormatInt
#define TclFormatInt \
(tclIntStubsPtr->tclFormatInt) /* 24 */
-#endif
-#ifndef TclFreePackageInfo
#define TclFreePackageInfo \
(tclIntStubsPtr->tclFreePackageInfo) /* 25 */
-#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */
-#ifndef TclpGetDefaultStdChannel
#define TclpGetDefaultStdChannel \
(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
-#endif
/* Slot 29 is reserved */
/* Slot 30 is reserved */
-#ifndef TclGetExtension
#define TclGetExtension \
(tclIntStubsPtr->tclGetExtension) /* 31 */
-#endif
-#ifndef TclGetFrame
#define TclGetFrame \
(tclIntStubsPtr->tclGetFrame) /* 32 */
-#endif
/* Slot 33 is reserved */
-#ifndef TclGetIntForIndex
#define TclGetIntForIndex \
(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
-#endif
/* Slot 35 is reserved */
-#ifndef TclGetLong
-#define TclGetLong \
- (tclIntStubsPtr->tclGetLong) /* 36 */
-#endif
-#ifndef TclGetLoadedPackages
+/* Slot 36 is reserved */
#define TclGetLoadedPackages \
(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
-#endif
-#ifndef TclGetNamespaceForQualName
#define TclGetNamespaceForQualName \
(tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
-#endif
-#ifndef TclGetObjInterpProc
#define TclGetObjInterpProc \
(tclIntStubsPtr->tclGetObjInterpProc) /* 39 */
-#endif
-#ifndef TclGetOpenMode
#define TclGetOpenMode \
(tclIntStubsPtr->tclGetOpenMode) /* 40 */
-#endif
-#ifndef TclGetOriginalCommand
#define TclGetOriginalCommand \
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
-#endif
-#ifndef TclpGetUserHome
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-#endif
/* Slot 43 is reserved */
-#ifndef TclGuessPackageName
#define TclGuessPackageName \
(tclIntStubsPtr->tclGuessPackageName) /* 44 */
-#endif
-#ifndef TclHideUnsafeCommands
#define TclHideUnsafeCommands \
(tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
-#endif
-#ifndef TclInExit
#define TclInExit \
(tclIntStubsPtr->tclInExit) /* 46 */
-#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
/* Slot 49 is reserved */
-#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
-#endif
-#ifndef TclInterpInit
#define TclInterpInit \
(tclIntStubsPtr->tclInterpInit) /* 51 */
-#endif
/* Slot 52 is reserved */
-#ifndef TclInvokeObjectCommand
#define TclInvokeObjectCommand \
(tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */
-#endif
-#ifndef TclInvokeStringCommand
#define TclInvokeStringCommand \
(tclIntStubsPtr->tclInvokeStringCommand) /* 54 */
-#endif
-#ifndef TclIsProc
#define TclIsProc \
(tclIntStubsPtr->tclIsProc) /* 55 */
-#endif
/* Slot 56 is reserved */
/* Slot 57 is reserved */
-#ifndef TclLookupVar
#define TclLookupVar \
(tclIntStubsPtr->tclLookupVar) /* 58 */
-#endif
/* Slot 59 is reserved */
-#ifndef TclNeedSpace
#define TclNeedSpace \
(tclIntStubsPtr->tclNeedSpace) /* 60 */
-#endif
-#ifndef TclNewProcBodyObj
#define TclNewProcBodyObj \
(tclIntStubsPtr->tclNewProcBodyObj) /* 61 */
-#endif
-#ifndef TclObjCommandComplete
#define TclObjCommandComplete \
(tclIntStubsPtr->tclObjCommandComplete) /* 62 */
-#endif
-#ifndef TclObjInterpProc
#define TclObjInterpProc \
(tclIntStubsPtr->tclObjInterpProc) /* 63 */
-#endif
-#ifndef TclObjInvoke
#define TclObjInvoke \
(tclIntStubsPtr->tclObjInvoke) /* 64 */
-#endif
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* Slot 67 is reserved */
/* Slot 68 is reserved */
-#ifndef TclpAlloc
#define TclpAlloc \
(tclIntStubsPtr->tclpAlloc) /* 69 */
-#endif
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
-#ifndef TclpFree
#define TclpFree \
(tclIntStubsPtr->tclpFree) /* 74 */
-#endif
-#ifndef TclpGetClicks
#define TclpGetClicks \
(tclIntStubsPtr->tclpGetClicks) /* 75 */
-#endif
-#ifndef TclpGetSeconds
#define TclpGetSeconds \
(tclIntStubsPtr->tclpGetSeconds) /* 76 */
-#endif
-#ifndef TclpGetTime
#define TclpGetTime \
(tclIntStubsPtr->tclpGetTime) /* 77 */
-#endif
-#ifndef TclpGetTimeZone
#define TclpGetTimeZone \
(tclIntStubsPtr->tclpGetTimeZone) /* 78 */
-#endif
/* Slot 79 is reserved */
/* Slot 80 is reserved */
-#ifndef TclpRealloc
#define TclpRealloc \
(tclIntStubsPtr->tclpRealloc) /* 81 */
-#endif
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
-#ifndef TclPrecTraceProc
#define TclPrecTraceProc \
(tclIntStubsPtr->tclPrecTraceProc) /* 88 */
-#endif
-#ifndef TclPreventAliasLoop
#define TclPreventAliasLoop \
(tclIntStubsPtr->tclPreventAliasLoop) /* 89 */
-#endif
/* Slot 90 is reserved */
-#ifndef TclProcCleanupProc
#define TclProcCleanupProc \
(tclIntStubsPtr->tclProcCleanupProc) /* 91 */
-#endif
-#ifndef TclProcCompileProc
#define TclProcCompileProc \
(tclIntStubsPtr->tclProcCompileProc) /* 92 */
-#endif
-#ifndef TclProcDeleteProc
#define TclProcDeleteProc \
(tclIntStubsPtr->tclProcDeleteProc) /* 93 */
-#endif
/* Slot 94 is reserved */
/* Slot 95 is reserved */
-#ifndef TclRenameCommand
#define TclRenameCommand \
(tclIntStubsPtr->tclRenameCommand) /* 96 */
-#endif
-#ifndef TclResetShadowedCmdRefs
#define TclResetShadowedCmdRefs \
(tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
-#endif
-#ifndef TclServiceIdle
#define TclServiceIdle \
(tclIntStubsPtr->tclServiceIdle) /* 98 */
-#endif
/* Slot 99 is reserved */
/* Slot 100 is reserved */
-#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
-#endif
-#ifndef TclSetupEnv
#define TclSetupEnv \
(tclIntStubsPtr->tclSetupEnv) /* 102 */
-#endif
-#ifndef TclSockGetPort
#define TclSockGetPort \
(tclIntStubsPtr->tclSockGetPort) /* 103 */
-#endif
-#ifndef TclSockMinimumBuffers
#define TclSockMinimumBuffers \
(tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
-#endif
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
-#ifndef TclTeardownNamespace
#define TclTeardownNamespace \
(tclIntStubsPtr->tclTeardownNamespace) /* 108 */
-#endif
-#ifndef TclUpdateReturnInfo
#define TclUpdateReturnInfo \
(tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
-#endif
/* Slot 110 is reserved */
-#ifndef Tcl_AddInterpResolvers
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#endif
-#ifndef Tcl_AppendExportList
#define Tcl_AppendExportList \
(tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#endif
-#ifndef Tcl_CreateNamespace
#define Tcl_CreateNamespace \
(tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#endif
-#ifndef Tcl_DeleteNamespace
#define Tcl_DeleteNamespace \
(tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#endif
-#ifndef Tcl_Export
#define Tcl_Export \
(tclIntStubsPtr->tcl_Export) /* 115 */
-#endif
-#ifndef Tcl_FindCommand
#define Tcl_FindCommand \
(tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#endif
-#ifndef Tcl_FindNamespace
#define Tcl_FindNamespace \
(tclIntStubsPtr->tcl_FindNamespace) /* 117 */
-#endif
-#ifndef Tcl_GetInterpResolvers
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
-#endif
-#ifndef Tcl_GetNamespaceResolvers
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
-#endif
-#ifndef Tcl_FindNamespaceVar
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#endif
-#ifndef Tcl_ForgetImport
#define Tcl_ForgetImport \
(tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#endif
-#ifndef Tcl_GetCommandFromObj
#define Tcl_GetCommandFromObj \
(tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#endif
-#ifndef Tcl_GetCommandFullName
#define Tcl_GetCommandFullName \
(tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#endif
-#ifndef Tcl_GetCurrentNamespace
#define Tcl_GetCurrentNamespace \
(tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#endif
-#ifndef Tcl_GetGlobalNamespace
#define Tcl_GetGlobalNamespace \
(tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
-#endif
-#ifndef Tcl_GetVariableFullName
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#endif
-#ifndef Tcl_Import
#define Tcl_Import \
(tclIntStubsPtr->tcl_Import) /* 127 */
-#endif
-#ifndef Tcl_PopCallFrame
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
-#endif
-#ifndef Tcl_PushCallFrame
#define Tcl_PushCallFrame \
(tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
-#endif
-#ifndef Tcl_RemoveInterpResolvers
#define Tcl_RemoveInterpResolvers \
(tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */
-#endif
-#ifndef Tcl_SetNamespaceResolvers
#define Tcl_SetNamespaceResolvers \
(tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */
-#endif
-#ifndef TclpHasSockets
#define TclpHasSockets \
(tclIntStubsPtr->tclpHasSockets) /* 132 */
-#endif
-#ifndef TclpGetDate
#define TclpGetDate \
(tclIntStubsPtr->tclpGetDate) /* 133 */
-#endif
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
-#ifndef TclGetEnv
#define TclGetEnv \
(tclIntStubsPtr->tclGetEnv) /* 138 */
-#endif
/* Slot 139 is reserved */
/* Slot 140 is reserved */
-#ifndef TclpGetCwd
#define TclpGetCwd \
(tclIntStubsPtr->tclpGetCwd) /* 141 */
-#endif
-#ifndef TclSetByteCodeFromAny
#define TclSetByteCodeFromAny \
(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
-#endif
-#ifndef TclAddLiteralObj
#define TclAddLiteralObj \
(tclIntStubsPtr->tclAddLiteralObj) /* 143 */
-#endif
-#ifndef TclHideLiteral
#define TclHideLiteral \
(tclIntStubsPtr->tclHideLiteral) /* 144 */
-#endif
-#ifndef TclGetAuxDataType
#define TclGetAuxDataType \
(tclIntStubsPtr->tclGetAuxDataType) /* 145 */
-#endif
-#ifndef TclHandleCreate
#define TclHandleCreate \
(tclIntStubsPtr->tclHandleCreate) /* 146 */
-#endif
-#ifndef TclHandleFree
#define TclHandleFree \
(tclIntStubsPtr->tclHandleFree) /* 147 */
-#endif
-#ifndef TclHandlePreserve
#define TclHandlePreserve \
(tclIntStubsPtr->tclHandlePreserve) /* 148 */
-#endif
-#ifndef TclHandleRelease
#define TclHandleRelease \
(tclIntStubsPtr->tclHandleRelease) /* 149 */
-#endif
-#ifndef TclRegAbout
#define TclRegAbout \
(tclIntStubsPtr->tclRegAbout) /* 150 */
-#endif
-#ifndef TclRegExpRangeUniChar
#define TclRegExpRangeUniChar \
(tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */
-#endif
-#ifndef TclSetLibraryPath
#define TclSetLibraryPath \
(tclIntStubsPtr->tclSetLibraryPath) /* 152 */
-#endif
-#ifndef TclGetLibraryPath
#define TclGetLibraryPath \
(tclIntStubsPtr->tclGetLibraryPath) /* 153 */
-#endif
/* Slot 154 is reserved */
/* Slot 155 is reserved */
-#ifndef TclRegError
#define TclRegError \
(tclIntStubsPtr->tclRegError) /* 156 */
-#endif
-#ifndef TclVarTraceExists
#define TclVarTraceExists \
(tclIntStubsPtr->tclVarTraceExists) /* 157 */
-#endif
-#ifndef TclSetStartupScriptFileName
-#define TclSetStartupScriptFileName \
- (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */
-#endif
-#ifndef TclGetStartupScriptFileName
-#define TclGetStartupScriptFileName \
- (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
-#endif
+/* Slot 158 is reserved */
+/* Slot 159 is reserved */
/* Slot 160 is reserved */
-#ifndef TclChannelTransform
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
-#endif
-#ifndef TclChannelEventScriptInvoker
#define TclChannelEventScriptInvoker \
(tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
-#endif
-#ifndef TclGetInstructionTable
#define TclGetInstructionTable \
(tclIntStubsPtr->tclGetInstructionTable) /* 163 */
-#endif
-#ifndef TclExpandCodeArray
#define TclExpandCodeArray \
(tclIntStubsPtr->tclExpandCodeArray) /* 164 */
-#endif
-#ifndef TclpSetInitialEncodings
#define TclpSetInitialEncodings \
(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
-#endif
-#ifndef TclListObjSetElement
#define TclListObjSetElement \
(tclIntStubsPtr->tclListObjSetElement) /* 166 */
-#endif
-#ifndef TclSetStartupScriptPath
-#define TclSetStartupScriptPath \
- (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
-#endif
-#ifndef TclGetStartupScriptPath
-#define TclGetStartupScriptPath \
- (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
-#endif
-#ifndef TclpUtfNcmp2
+/* Slot 167 is reserved */
+/* Slot 168 is reserved */
#define TclpUtfNcmp2 \
(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
-#endif
-#ifndef TclCheckInterpTraces
#define TclCheckInterpTraces \
(tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
-#endif
-#ifndef TclCheckExecutionTraces
#define TclCheckExecutionTraces \
(tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */
-#endif
-#ifndef TclInThreadExit
#define TclInThreadExit \
(tclIntStubsPtr->tclInThreadExit) /* 172 */
-#endif
-#ifndef TclUniCharMatch
#define TclUniCharMatch \
(tclIntStubsPtr->tclUniCharMatch) /* 173 */
-#endif
/* Slot 174 is reserved */
-#ifndef TclCallVarTraces
#define TclCallVarTraces \
(tclIntStubsPtr->tclCallVarTraces) /* 175 */
-#endif
-#ifndef TclCleanupVar
#define TclCleanupVar \
(tclIntStubsPtr->tclCleanupVar) /* 176 */
-#endif
-#ifndef TclVarErrMsg
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-#endif
-#ifndef Tcl_SetStartupScript
-#define Tcl_SetStartupScript \
- (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
-#endif
-#ifndef Tcl_GetStartupScript
-#define Tcl_GetStartupScript \
- (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
-#endif
+/* Slot 178 is reserved */
+/* Slot 179 is reserved */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
-#ifndef TclpLocaltime
#define TclpLocaltime \
(tclIntStubsPtr->tclpLocaltime) /* 182 */
-#endif
-#ifndef TclpGmtime
#define TclpGmtime \
(tclIntStubsPtr->tclpGmtime) /* 183 */
-#endif
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
@@ -1884,156 +1186,103 @@ extern TclIntStubs *tclIntStubsPtr;
/* Slot 195 is reserved */
/* Slot 196 is reserved */
/* Slot 197 is reserved */
-#ifndef TclObjGetFrame
#define TclObjGetFrame \
(tclIntStubsPtr->tclObjGetFrame) /* 198 */
-#endif
/* Slot 199 is reserved */
-#ifndef TclpObjRemoveDirectory
#define TclpObjRemoveDirectory \
(tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */
-#endif
-#ifndef TclpObjCopyDirectory
#define TclpObjCopyDirectory \
(tclIntStubsPtr->tclpObjCopyDirectory) /* 201 */
-#endif
-#ifndef TclpObjCreateDirectory
#define TclpObjCreateDirectory \
(tclIntStubsPtr->tclpObjCreateDirectory) /* 202 */
-#endif
-#ifndef TclpObjDeleteFile
#define TclpObjDeleteFile \
(tclIntStubsPtr->tclpObjDeleteFile) /* 203 */
-#endif
-#ifndef TclpObjCopyFile
#define TclpObjCopyFile \
(tclIntStubsPtr->tclpObjCopyFile) /* 204 */
-#endif
-#ifndef TclpObjRenameFile
#define TclpObjRenameFile \
(tclIntStubsPtr->tclpObjRenameFile) /* 205 */
-#endif
-#ifndef TclpObjStat
#define TclpObjStat \
(tclIntStubsPtr->tclpObjStat) /* 206 */
-#endif
-#ifndef TclpObjAccess
#define TclpObjAccess \
(tclIntStubsPtr->tclpObjAccess) /* 207 */
-#endif
-#ifndef TclpOpenFileChannel
#define TclpOpenFileChannel \
(tclIntStubsPtr->tclpOpenFileChannel) /* 208 */
-#endif
/* Slot 209 is reserved */
/* Slot 210 is reserved */
/* Slot 211 is reserved */
-#ifndef TclpFindExecutable
#define TclpFindExecutable \
(tclIntStubsPtr->tclpFindExecutable) /* 212 */
-#endif
-#ifndef TclGetObjNameOfExecutable
#define TclGetObjNameOfExecutable \
(tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */
-#endif
-#ifndef TclSetObjNameOfExecutable
#define TclSetObjNameOfExecutable \
(tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */
-#endif
-#ifndef TclStackAlloc
#define TclStackAlloc \
(tclIntStubsPtr->tclStackAlloc) /* 215 */
-#endif
-#ifndef TclStackFree
#define TclStackFree \
(tclIntStubsPtr->tclStackFree) /* 216 */
-#endif
-#ifndef TclPushStackFrame
#define TclPushStackFrame \
(tclIntStubsPtr->tclPushStackFrame) /* 217 */
-#endif
-#ifndef TclPopStackFrame
#define TclPopStackFrame \
(tclIntStubsPtr->tclPopStackFrame) /* 218 */
-#endif
/* Slot 219 is reserved */
/* Slot 220 is reserved */
/* Slot 221 is reserved */
/* Slot 222 is reserved */
/* Slot 223 is reserved */
-#ifndef TclGetPlatform
#define TclGetPlatform \
(tclIntStubsPtr->tclGetPlatform) /* 224 */
-#endif
-#ifndef TclTraceDictPath
#define TclTraceDictPath \
(tclIntStubsPtr->tclTraceDictPath) /* 225 */
-#endif
-#ifndef TclObjBeingDeleted
#define TclObjBeingDeleted \
(tclIntStubsPtr->tclObjBeingDeleted) /* 226 */
-#endif
-#ifndef TclSetNsPath
#define TclSetNsPath \
(tclIntStubsPtr->tclSetNsPath) /* 227 */
-#endif
-#ifndef TclObjInterpProcCore
-#define TclObjInterpProcCore \
- (tclIntStubsPtr->tclObjInterpProcCore) /* 228 */
-#endif
-#ifndef TclPtrMakeUpvar
+/* Slot 228 is reserved */
#define TclPtrMakeUpvar \
(tclIntStubsPtr->tclPtrMakeUpvar) /* 229 */
-#endif
-#ifndef TclObjLookupVar
#define TclObjLookupVar \
(tclIntStubsPtr->tclObjLookupVar) /* 230 */
-#endif
-#ifndef TclGetNamespaceFromObj
#define TclGetNamespaceFromObj \
(tclIntStubsPtr->tclGetNamespaceFromObj) /* 231 */
-#endif
-#ifndef TclEvalObjEx
#define TclEvalObjEx \
(tclIntStubsPtr->tclEvalObjEx) /* 232 */
-#endif
-#ifndef TclGetSrcInfoForPc
#define TclGetSrcInfoForPc \
(tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */
-#endif
-#ifndef TclVarHashCreateVar
#define TclVarHashCreateVar \
(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
-#endif
-#ifndef TclInitVarHashTable
#define TclInitVarHashTable \
(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
-#endif
-#ifndef TclBackgroundException
-#define TclBackgroundException \
- (tclIntStubsPtr->tclBackgroundException) /* 236 */
-#endif
-/* Slot 237 is reserved */
-/* Slot 238 is reserved */
-/* Slot 239 is reserved */
-/* Slot 240 is reserved */
-/* Slot 241 is reserved */
-/* Slot 242 is reserved */
-#ifndef TclDbDumpActiveObjects
+/* Slot 236 is reserved */
+#define TclResetCancellation \
+ (tclIntStubsPtr->tclResetCancellation) /* 237 */
+#define TclNRInterpProc \
+ (tclIntStubsPtr->tclNRInterpProc) /* 238 */
+#define TclNRInterpProcCore \
+ (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */
+#define TclNRRunCallbacks \
+ (tclIntStubsPtr->tclNRRunCallbacks) /* 240 */
+#define TclNREvalObjEx \
+ (tclIntStubsPtr->tclNREvalObjEx) /* 241 */
+#define TclNREvalObjv \
+ (tclIntStubsPtr->tclNREvalObjv) /* 242 */
#define TclDbDumpActiveObjects \
(tclIntStubsPtr->tclDbDumpActiveObjects) /* 243 */
-#endif
-/* Slot 244 is reserved */
-/* Slot 245 is reserved */
-/* Slot 246 is reserved */
-/* Slot 247 is reserved */
-/* Slot 248 is reserved */
-#ifndef TclDoubleDigits
+#define TclGetNamespaceChildTable \
+ (tclIntStubsPtr->tclGetNamespaceChildTable) /* 244 */
+#define TclGetNamespaceCommandTable \
+ (tclIntStubsPtr->tclGetNamespaceCommandTable) /* 245 */
+#define TclInitRewriteEnsemble \
+ (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */
+#define TclResetRewriteEnsemble \
+ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */
+#define TclCopyChannel \
+ (tclIntStubsPtr->tclCopyChannel) /* 248 */
#define TclDoubleDigits \
(tclIntStubsPtr->tclDoubleDigits) /* 249 */
-#endif
+#define TclSetSlaveCancelFlags \
+ (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */
-#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 3c03015..0f1c0d1 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -37,388 +37,217 @@
*/
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef TclGetAndDetachPids_TCL_DECLARED
-#define TclGetAndDetachPids_TCL_DECLARED
/* 0 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef TclpCloseFile_TCL_DECLARED
-#define TclpCloseFile_TCL_DECLARED
/* 1 */
EXTERN int TclpCloseFile(TclFile file);
-#endif
-#ifndef TclpCreateCommandChannel_TCL_DECLARED
-#define TclpCreateCommandChannel_TCL_DECLARED
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
-#endif
-#ifndef TclpCreatePipe_TCL_DECLARED
-#define TclpCreatePipe_TCL_DECLARED
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-#endif
-#ifndef TclpCreateProcess_TCL_DECLARED
-#define TclpCreateProcess_TCL_DECLARED
/* 4 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- CONST char **argv, TclFile inputFile,
+ const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
-#endif
/* Slot 5 is reserved */
-#ifndef TclpMakeFile_TCL_DECLARED
-#define TclpMakeFile_TCL_DECLARED
/* 6 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-#endif
-#ifndef TclpOpenFile_TCL_DECLARED
-#define TclpOpenFile_TCL_DECLARED
/* 7 */
-EXTERN TclFile TclpOpenFile(CONST char *fname, int mode);
-#endif
-#ifndef TclUnixWaitForFile_TCL_DECLARED
-#define TclUnixWaitForFile_TCL_DECLARED
+EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
-#endif
-#ifndef TclpCreateTempFile_TCL_DECLARED
-#define TclpCreateTempFile_TCL_DECLARED
/* 9 */
-EXTERN TclFile TclpCreateTempFile(CONST char *contents);
-#endif
-#ifndef TclpReaddir_TCL_DECLARED
-#define TclpReaddir_TCL_DECLARED
+EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir);
-#endif
-#ifndef TclpLocaltime_unix_TCL_DECLARED
-#define TclpLocaltime_unix_TCL_DECLARED
/* 11 */
-EXTERN struct tm * TclpLocaltime_unix(CONST time_t *clock);
-#endif
-#ifndef TclpGmtime_unix_TCL_DECLARED
-#define TclpGmtime_unix_TCL_DECLARED
+EXTERN struct tm * TclpLocaltime_unix(const time_t *clock);
/* 12 */
-EXTERN struct tm * TclpGmtime_unix(CONST time_t *clock);
-#endif
-#ifndef TclpInetNtoa_TCL_DECLARED
-#define TclpInetNtoa_TCL_DECLARED
+EXTERN struct tm * TclpGmtime_unix(const time_t *clock);
/* 13 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
-#endif
-#ifndef TclUnixCopyFile_TCL_DECLARED
-#define TclUnixCopyFile_TCL_DECLARED
/* 14 */
-EXTERN int TclUnixCopyFile(CONST char *src, CONST char *dst,
- CONST Tcl_StatBuf *statBufPtr,
+EXTERN int TclUnixCopyFile(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
-#endif
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
-#ifndef TclWinConvertError_TCL_DECLARED
-#define TclWinConvertError_TCL_DECLARED
/* 0 */
EXTERN void TclWinConvertError(unsigned long errCode);
-#endif
-#ifndef TclWinConvertWSAError_TCL_DECLARED
-#define TclWinConvertWSAError_TCL_DECLARED
/* 1 */
EXTERN void TclWinConvertWSAError(unsigned long errCode);
-#endif
-#ifndef TclWinGetServByName_TCL_DECLARED
-#define TclWinGetServByName_TCL_DECLARED
/* 2 */
-EXTERN struct servent * TclWinGetServByName(CONST char *nm,
- CONST char *proto);
-#endif
-#ifndef TclWinGetSockOpt_TCL_DECLARED
-#define TclWinGetSockOpt_TCL_DECLARED
+EXTERN struct servent * TclWinGetServByName(const char *nm,
+ const char *proto);
/* 3 */
-EXTERN int TclWinGetSockOpt(int s, int level, int optname,
+EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname,
char FAR *optval, int FAR *optlen);
-#endif
-#ifndef TclWinGetTclInstance_TCL_DECLARED
-#define TclWinGetTclInstance_TCL_DECLARED
/* 4 */
EXTERN HINSTANCE TclWinGetTclInstance(void);
-#endif
/* Slot 5 is reserved */
-#ifndef TclWinNToHS_TCL_DECLARED
-#define TclWinNToHS_TCL_DECLARED
/* 6 */
EXTERN u_short TclWinNToHS(u_short ns);
-#endif
-#ifndef TclWinSetSockOpt_TCL_DECLARED
-#define TclWinSetSockOpt_TCL_DECLARED
/* 7 */
-EXTERN int TclWinSetSockOpt(int s, int level, int optname,
- CONST char FAR *optval, int optlen);
-#endif
-#ifndef TclpGetPid_TCL_DECLARED
-#define TclpGetPid_TCL_DECLARED
+EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname,
+ const char FAR *optval, int optlen);
/* 8 */
EXTERN unsigned long TclpGetPid(Tcl_Pid pid);
-#endif
-#ifndef TclWinGetPlatformId_TCL_DECLARED
-#define TclWinGetPlatformId_TCL_DECLARED
/* 9 */
EXTERN int TclWinGetPlatformId(void);
-#endif
/* Slot 10 is reserved */
-#ifndef TclGetAndDetachPids_TCL_DECLARED
-#define TclGetAndDetachPids_TCL_DECLARED
/* 11 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef TclpCloseFile_TCL_DECLARED
-#define TclpCloseFile_TCL_DECLARED
/* 12 */
EXTERN int TclpCloseFile(TclFile file);
-#endif
-#ifndef TclpCreateCommandChannel_TCL_DECLARED
-#define TclpCreateCommandChannel_TCL_DECLARED
/* 13 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
-#endif
-#ifndef TclpCreatePipe_TCL_DECLARED
-#define TclpCreatePipe_TCL_DECLARED
/* 14 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-#endif
-#ifndef TclpCreateProcess_TCL_DECLARED
-#define TclpCreateProcess_TCL_DECLARED
/* 15 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- CONST char **argv, TclFile inputFile,
+ const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
-#endif
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-#ifndef TclpMakeFile_TCL_DECLARED
-#define TclpMakeFile_TCL_DECLARED
/* 18 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-#endif
-#ifndef TclpOpenFile_TCL_DECLARED
-#define TclpOpenFile_TCL_DECLARED
/* 19 */
-EXTERN TclFile TclpOpenFile(CONST char *fname, int mode);
-#endif
-#ifndef TclWinAddProcess_TCL_DECLARED
-#define TclWinAddProcess_TCL_DECLARED
+EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
-EXTERN void TclWinAddProcess(VOID *hProcess, unsigned long id);
-#endif
+EXTERN void TclWinAddProcess(void *hProcess, unsigned long id);
/* Slot 21 is reserved */
-#ifndef TclpCreateTempFile_TCL_DECLARED
-#define TclpCreateTempFile_TCL_DECLARED
/* 22 */
-EXTERN TclFile TclpCreateTempFile(CONST char *contents);
-#endif
-#ifndef TclpGetTZName_TCL_DECLARED
-#define TclpGetTZName_TCL_DECLARED
+EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 23 */
EXTERN char * TclpGetTZName(int isdst);
-#endif
-#ifndef TclWinNoBackslash_TCL_DECLARED
-#define TclWinNoBackslash_TCL_DECLARED
/* 24 */
EXTERN char * TclWinNoBackslash(char *path);
-#endif
/* Slot 25 is reserved */
-#ifndef TclWinSetInterfaces_TCL_DECLARED
-#define TclWinSetInterfaces_TCL_DECLARED
/* 26 */
EXTERN void TclWinSetInterfaces(int wide);
-#endif
-#ifndef TclWinFlushDirtyChannels_TCL_DECLARED
-#define TclWinFlushDirtyChannels_TCL_DECLARED
/* 27 */
EXTERN void TclWinFlushDirtyChannels(void);
-#endif
-#ifndef TclWinResetInterfaces_TCL_DECLARED
-#define TclWinResetInterfaces_TCL_DECLARED
/* 28 */
EXTERN void TclWinResetInterfaces(void);
-#endif
-#ifndef TclWinCPUID_TCL_DECLARED
-#define TclWinCPUID_TCL_DECLARED
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
-#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef TclGetAndDetachPids_TCL_DECLARED
-#define TclGetAndDetachPids_TCL_DECLARED
/* 0 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
-#endif
-#ifndef TclpCloseFile_TCL_DECLARED
-#define TclpCloseFile_TCL_DECLARED
/* 1 */
EXTERN int TclpCloseFile(TclFile file);
-#endif
-#ifndef TclpCreateCommandChannel_TCL_DECLARED
-#define TclpCreateCommandChannel_TCL_DECLARED
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
int numPids, Tcl_Pid *pidPtr);
-#endif
-#ifndef TclpCreatePipe_TCL_DECLARED
-#define TclpCreatePipe_TCL_DECLARED
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-#endif
-#ifndef TclpCreateProcess_TCL_DECLARED
-#define TclpCreateProcess_TCL_DECLARED
/* 4 */
EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- CONST char **argv, TclFile inputFile,
+ const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
-#endif
/* Slot 5 is reserved */
-#ifndef TclpMakeFile_TCL_DECLARED
-#define TclpMakeFile_TCL_DECLARED
/* 6 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-#endif
-#ifndef TclpOpenFile_TCL_DECLARED
-#define TclpOpenFile_TCL_DECLARED
/* 7 */
-EXTERN TclFile TclpOpenFile(CONST char *fname, int mode);
-#endif
-#ifndef TclUnixWaitForFile_TCL_DECLARED
-#define TclUnixWaitForFile_TCL_DECLARED
+EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
-#endif
-#ifndef TclpCreateTempFile_TCL_DECLARED
-#define TclpCreateTempFile_TCL_DECLARED
/* 9 */
-EXTERN TclFile TclpCreateTempFile(CONST char *contents);
-#endif
-#ifndef TclpReaddir_TCL_DECLARED
-#define TclpReaddir_TCL_DECLARED
+EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir);
-#endif
-#ifndef TclpLocaltime_unix_TCL_DECLARED
-#define TclpLocaltime_unix_TCL_DECLARED
/* 11 */
-EXTERN struct tm * TclpLocaltime_unix(CONST time_t *clock);
-#endif
-#ifndef TclpGmtime_unix_TCL_DECLARED
-#define TclpGmtime_unix_TCL_DECLARED
+EXTERN struct tm * TclpLocaltime_unix(const time_t *clock);
/* 12 */
-EXTERN struct tm * TclpGmtime_unix(CONST time_t *clock);
-#endif
-#ifndef TclpInetNtoa_TCL_DECLARED
-#define TclpInetNtoa_TCL_DECLARED
+EXTERN struct tm * TclpGmtime_unix(const time_t *clock);
/* 13 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
-#endif
-#ifndef TclUnixCopyFile_TCL_DECLARED
-#define TclUnixCopyFile_TCL_DECLARED
/* 14 */
-EXTERN int TclUnixCopyFile(CONST char *src, CONST char *dst,
- CONST Tcl_StatBuf *statBufPtr,
+EXTERN int TclUnixCopyFile(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
-#endif
-#ifndef TclMacOSXGetFileAttribute_TCL_DECLARED
-#define TclMacOSXGetFileAttribute_TCL_DECLARED
/* 15 */
EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr);
-#endif
-#ifndef TclMacOSXSetFileAttribute_TCL_DECLARED
-#define TclMacOSXSetFileAttribute_TCL_DECLARED
/* 16 */
EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr);
-#endif
-#ifndef TclMacOSXCopyFileAttributes_TCL_DECLARED
-#define TclMacOSXCopyFileAttributes_TCL_DECLARED
/* 17 */
-EXTERN int TclMacOSXCopyFileAttributes(CONST char *src,
- CONST char *dst,
- CONST Tcl_StatBuf *statBufPtr);
-#endif
-#ifndef TclMacOSXMatchType_TCL_DECLARED
-#define TclMacOSXMatchType_TCL_DECLARED
+EXTERN int TclMacOSXCopyFileAttributes(const char *src,
+ const char *dst,
+ const Tcl_StatBuf *statBufPtr);
/* 18 */
EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
- CONST char *pathName, CONST char *fileName,
+ const char *pathName, const char *fileName,
Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types);
-#endif
-#ifndef TclMacOSXNotifierAddRunLoopMode_TCL_DECLARED
-#define TclMacOSXNotifierAddRunLoopMode_TCL_DECLARED
/* 19 */
EXTERN void TclMacOSXNotifierAddRunLoopMode(
- CONST VOID *runLoopMode);
-#endif
+ const void *runLoopMode);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
- struct TclIntPlatStubHooks *hooks;
+ const struct TclIntPlatStubHooks *hooks;
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
- VOID *reserved5;
+ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
+ void (*reserved5)(void);
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */
+ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- TclFile (*tclpCreateTempFile) (CONST char *contents); /* 9 */
+ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
- struct tm * (*tclpLocaltime_unix) (CONST time_t *clock); /* 11 */
- struct tm * (*tclpGmtime_unix) (CONST time_t *clock); /* 12 */
+ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
+ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
- int (*tclUnixCopyFile) (CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
+ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
void (*tclWinConvertError) (unsigned long errCode); /* 0 */
void (*tclWinConvertWSAError) (unsigned long errCode); /* 1 */
- struct servent * (*tclWinGetServByName) (CONST char *nm, CONST char *proto); /* 2 */
- int (*tclWinGetSockOpt) (int s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */
+ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
+ int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
- VOID *reserved5;
+ void (*reserved5)(void);
u_short (*tclWinNToHS) (u_short ns); /* 6 */
- int (*tclWinSetSockOpt) (int s, int level, int optname, CONST char FAR *optval, int optlen); /* 7 */
+ int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char FAR *optval, int optlen); /* 7 */
unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
- VOID *reserved10;
+ void (*reserved10)(void);
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
- VOID *reserved16;
- VOID *reserved17;
+ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
+ void (*reserved16)(void);
+ void (*reserved17)(void);
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
- TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 19 */
- void (*tclWinAddProcess) (VOID *hProcess, unsigned long id); /* 20 */
- VOID *reserved21;
- TclFile (*tclpCreateTempFile) (CONST char *contents); /* 22 */
+ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
+ void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */
+ void (*reserved21)(void);
+ TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
char * (*tclpGetTZName) (int isdst); /* 23 */
char * (*tclWinNoBackslash) (char *path); /* 24 */
- VOID *reserved25;
+ void (*reserved25)(void);
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
@@ -429,283 +258,169 @@ typedef struct TclIntPlatStubs {
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
- VOID *reserved5;
+ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
+ void (*reserved5)(void);
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */
+ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- TclFile (*tclpCreateTempFile) (CONST char *contents); /* 9 */
+ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
- struct tm * (*tclpLocaltime_unix) (CONST time_t *clock); /* 11 */
- struct tm * (*tclpGmtime_unix) (CONST time_t *clock); /* 12 */
+ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
+ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
- int (*tclUnixCopyFile) (CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
+ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
- int (*tclMacOSXCopyFileAttributes) (CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr); /* 17 */
- int (*tclMacOSXMatchType) (Tcl_Interp *interp, CONST char *pathName, CONST char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
- void (*tclMacOSXNotifierAddRunLoopMode) (CONST VOID *runLoopMode); /* 19 */
+ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
+ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
+ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
#endif /* MACOSX */
} TclIntPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
-extern TclIntPlatStubs *tclIntPlatStubsPtr;
+extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#ifdef __cplusplus
}
#endif
-#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#endif
-#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
-#endif
-#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
-#endif
-#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#endif
-#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
-#endif
/* Slot 5 is reserved */
-#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#endif
-#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
-#endif
-#ifndef TclUnixWaitForFile
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#endif
-#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
-#endif
-#ifndef TclpReaddir
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
-#endif
-#ifndef TclpLocaltime_unix
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
-#endif
-#ifndef TclpGmtime_unix
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
-#endif
-#ifndef TclpInetNtoa
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
-#endif
-#ifndef TclUnixCopyFile
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-#endif
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
-#ifndef TclWinConvertError
#define TclWinConvertError \
(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
-#endif
-#ifndef TclWinConvertWSAError
#define TclWinConvertWSAError \
(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
-#endif
-#ifndef TclWinGetServByName
#define TclWinGetServByName \
(tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
-#endif
-#ifndef TclWinGetSockOpt
#define TclWinGetSockOpt \
(tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
-#endif
-#ifndef TclWinGetTclInstance
#define TclWinGetTclInstance \
(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
-#endif
/* Slot 5 is reserved */
-#ifndef TclWinNToHS
#define TclWinNToHS \
(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
-#endif
-#ifndef TclWinSetSockOpt
#define TclWinSetSockOpt \
(tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
-#endif
-#ifndef TclpGetPid
#define TclpGetPid \
(tclIntPlatStubsPtr->tclpGetPid) /* 8 */
-#endif
-#ifndef TclWinGetPlatformId
#define TclWinGetPlatformId \
(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
-#endif
/* Slot 10 is reserved */
-#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
-#endif
-#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
-#endif
-#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
-#endif
-#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
-#endif
-#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
-#endif
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
-#endif
-#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
-#endif
-#ifndef TclWinAddProcess
#define TclWinAddProcess \
(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
-#endif
/* Slot 21 is reserved */
-#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-#endif
-#ifndef TclpGetTZName
#define TclpGetTZName \
(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
-#endif
-#ifndef TclWinNoBackslash
#define TclWinNoBackslash \
(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
-#endif
/* Slot 25 is reserved */
-#ifndef TclWinSetInterfaces
#define TclWinSetInterfaces \
(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
-#endif
-#ifndef TclWinFlushDirtyChannels
#define TclWinFlushDirtyChannels \
(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
-#endif
-#ifndef TclWinResetInterfaces
#define TclWinResetInterfaces \
(tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
-#endif
-#ifndef TclWinCPUID
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#endif
-#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
-#endif
-#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
-#endif
-#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#endif
-#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
-#endif
/* Slot 5 is reserved */
-#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#endif
-#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
-#endif
-#ifndef TclUnixWaitForFile
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#endif
-#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
-#endif
-#ifndef TclpReaddir
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
-#endif
-#ifndef TclpLocaltime_unix
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
-#endif
-#ifndef TclpGmtime_unix
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
-#endif
-#ifndef TclpInetNtoa
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
-#endif
-#ifndef TclUnixCopyFile
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-#endif
-#ifndef TclMacOSXGetFileAttribute
#define TclMacOSXGetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
-#endif
-#ifndef TclMacOSXSetFileAttribute
#define TclMacOSXSetFileAttribute \
(tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
-#endif
-#ifndef TclMacOSXCopyFileAttributes
#define TclMacOSXCopyFileAttributes \
(tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
-#endif
-#ifndef TclMacOSXMatchType
#define TclMacOSXMatchType \
(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
-#endif
-#ifndef TclMacOSXNotifierAddRunLoopMode
#define TclMacOSXNotifierAddRunLoopMode \
(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-#endif
#endif /* MACOSX */
-#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0b05913..a156a57 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -19,7 +19,7 @@
* above. This variable can be modified by the function below.
*/
-static char *tclPreInitScript = NULL;
+static const char *tclPreInitScript = NULL;
/* Forward declaration */
struct Target;
@@ -194,6 +194,9 @@ static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
static int AliasObjCmd(ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *const objv[]);
+static int AliasNRCmd(ClientData dummy,
+ Tcl_Interp *currentInterp, int objc,
+ Tcl_Obj *const objv[]);
static void AliasObjCmdDeleteProc(ClientData clientData);
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc,
@@ -263,11 +266,11 @@ static void TimeLimitCallback(ClientData clientData);
*----------------------------------------------------------------------
*/
-char *
+const char *
TclSetPreInitScript(
- char *string) /* Pointer to a script. */
+ const char *string) /* Pointer to a script. */
{
- char *prevString = tclPreInitScript;
+ const char *prevString = tclPreInitScript;
tclPreInitScript = string;
return(prevString);
}
@@ -297,8 +300,8 @@ Tcl_Init(
{
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return (TCL_ERROR);
- };
+ return TCL_ERROR;
+ }
}
/*
@@ -433,7 +436,7 @@ TclInterpInit(
Master *masterPtr;
Slave *slavePtr;
- interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
+ interpInfoPtr = ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
masterPtr = &interpInfoPtr->master;
@@ -529,7 +532,7 @@ InterpInfoDeleteProc(
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
- ckfree((char *) interpInfoPtr);
+ ckfree(interpInfoPtr);
}
/*
@@ -556,21 +559,24 @@ Tcl_InterpObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ Tcl_Interp *slaveInterp;
int index;
- static const char *options[] = {
- "alias", "aliases", "bgerror", "create",
- "debug", "delete", "eval", "exists", "expose",
- "hide", "hidden", "issafe", "invokehidden",
- "limit", "marktrusted", "recursionlimit","slaves",
- "share", "target", "transfer",
+ static const char *const options[] = {
+ "alias", "aliases", "bgerror", "cancel",
+ "create", "debug", "delete",
+ "eval", "exists", "expose",
+ "hide", "hidden", "issafe",
+ "invokehidden", "limit", "marktrusted", "recursionlimit",
+ "slaves", "share", "target", "transfer",
NULL
};
enum option {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE,
- OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
- OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
- OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES,
- OPT_SHARE, OPT_TARGET, OPT_TRANSFER
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
+ OPT_CREATE, OPT_DEBUG, OPT_DELETE,
+ OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
+ OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
+ OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
+ OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
@@ -583,12 +589,12 @@ Tcl_InterpObjCmd(
}
switch ((enum option) index) {
case OPT_ALIAS: {
- Tcl_Interp *slaveInterp, *masterInterp;
+ Tcl_Interp *masterInterp;
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
+ "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
@@ -617,18 +623,13 @@ Tcl_InterpObjCmd(
}
goto aliasArgs;
}
- case OPT_ALIASES: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_ALIASES:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return AliasList(interp, slaveInterp);
- }
- case OPT_BGERROR: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_BGERROR:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
return TCL_ERROR;
@@ -638,12 +639,83 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
+ case OPT_CANCEL: {
+ int i, flags;
+ Tcl_Obj *resultObjPtr;
+ static const char *const cancelOptions[] = {
+ "-unwind", "--", NULL
+ };
+ enum option {
+ OPT_UNWIND, OPT_LAST
+ };
+
+ flags = 0;
+
+ for (i = 2; i < objc; i++) {
+ if (TclGetString(objv[i])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option",
+ 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum option) index) {
+ case OPT_UNWIND:
+ /*
+ * The evaluation stack in the target interp is to be unwound.
+ */
+
+ flags |= TCL_CANCEL_UNWIND;
+ break;
+ case OPT_LAST:
+ i++;
+ goto endOfForLoop;
+ }
+ }
+
+ endOfForLoop:
+ if ((i + 2) < objc) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-unwind? ?--? ?path? ?result?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Did they specify a slave interp to cancel the script in progress
+ * in? If not, use the current interp.
+ */
+
+ if (i < objc) {
+ slaveInterp = GetInterp(interp, objv[i]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ i++;
+ } else {
+ slaveInterp = interp;
+ }
+
+ if (i < objc) {
+ resultObjPtr = objv[i];
+
+ /*
+ * Tcl_CancelEval removes this reference.
+ */
+
+ Tcl_IncrRefCount(resultObjPtr);
+ i++;
+ } else {
+ resultObjPtr = NULL;
+ }
+
+ return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *slavePtr;
char buf[16 + TCL_INTEGER_SPACE];
- static const char *options[] = {
+ static const char *const createOptions[] = {
"-safe", "--", NULL
};
enum option {
@@ -660,8 +732,8 @@ Tcl_InterpObjCmd(
last = 0;
for (i = 2; i < objc; i++) {
if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
+ "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_SAFE) {
@@ -707,13 +779,11 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, slavePtr);
return TCL_OK;
}
- case OPT_DEBUG: {
- /* TIP #378 */
- Tcl_Interp *slaveInterp;
-
+ case OPT_DEBUG: /* TIP #378 */
/*
* Currently only -frame supported, otherwise ?-option ?value??
*/
+
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
return TCL_ERROR;
@@ -723,11 +793,9 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
- Tcl_Interp *slaveInterp;
for (i = 2; i < objc; i++) {
slaveInterp = GetInterp(interp, objv[i]);
@@ -736,6 +804,8 @@ Tcl_InterpObjCmd(
} else if (slaveInterp == interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot delete the current interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "DELETESELF", NULL);
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
@@ -744,9 +814,7 @@ Tcl_InterpObjCmd(
}
return TCL_OK;
}
- case OPT_EVAL: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_EVAL:
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
@@ -756,12 +824,9 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_EXISTS: {
- int exists;
- Tcl_Interp *slaveInterp;
+ int exists = 1;
- exists = 1;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
if (objc > 3) {
@@ -773,9 +838,7 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
return TCL_OK;
}
- case OPT_EXPOSE: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_EXPOSE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
@@ -785,10 +848,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
- }
- case OPT_HIDE: {
- Tcl_Interp *slaveInterp; /* A slave. */
-
+ case OPT_HIDE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
return TCL_ERROR;
@@ -798,31 +858,23 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
- }
- case OPT_HIDDEN: {
- Tcl_Interp *slaveInterp; /* A slave. */
-
+ case OPT_HIDDEN:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveHidden(interp, slaveInterp);
- }
- case OPT_ISSAFE: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_ISSAFE:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
return TCL_OK;
- }
case OPT_INVOKEHID: {
- int i, index;
+ int i;
const char *namespaceName;
- Tcl_Interp *slaveInterp;
- static const char *hiddenOptions[] = {
+ static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
enum hiddenOption {
@@ -864,8 +916,7 @@ Tcl_InterpObjCmd(
objv + i);
}
case OPT_LIMIT: {
- Tcl_Interp *slaveInterp;
- static const char *limitTypes[] = {
+ static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
@@ -874,7 +925,8 @@ Tcl_InterpObjCmd(
int limitType;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path limitType ?-option value ...?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
@@ -892,9 +944,7 @@ Tcl_InterpObjCmd(
return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
}
}
- case OPT_MARKTRUSTED: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
@@ -904,10 +954,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
- }
- case OPT_RECLIMIT: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_RECLIMIT:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
return TCL_ERROR;
@@ -917,9 +964,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_SLAVES: {
- Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
@@ -943,8 +988,7 @@ Tcl_InterpObjCmd(
}
case OPT_TRANSFER:
case OPT_SHARE: {
- Tcl_Interp *slaveInterp; /* A slave. */
- Tcl_Interp *masterInterp; /* Its master. */
+ Tcl_Interp *masterInterp; /* The master of the slave. */
Tcl_Channel chan;
if (objc != 5) {
@@ -957,7 +1001,7 @@ Tcl_InterpObjCmd(
}
chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL);
if (chan == NULL) {
- TclTransferResult(masterInterp, TCL_OK, interp);
+ Tcl_TransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[4]);
@@ -972,18 +1016,17 @@ Tcl_InterpObjCmd(
*/
if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
- TclTransferResult(masterInterp, TCL_OK, interp);
+ Tcl_TransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
}
}
return TCL_OK;
}
case OPT_TARGET: {
- Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
- char *aliasName;
+ const char *aliasName;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
@@ -1012,6 +1055,8 @@ Tcl_InterpObjCmd(
Tcl_AppendResult(interp, "target interpreter for alias \"",
aliasName, "\" in path \"", Tcl_GetString(objv[2]),
"\" is not my descendant", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "TARGETSHROUDED", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1088,8 +1133,7 @@ Tcl_CreateAlias(
int i;
int result;
- objv = (Tcl_Obj **)
- TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc);
+ objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
@@ -1209,7 +1253,7 @@ Tcl_GetAlias(
}
if (argvPtr != NULL) {
*argvPtr = (const char **)
- ckalloc((unsigned) sizeof(const char *) * (objc - 1));
+ ckalloc(sizeof(const char *) * (objc - 1));
for (i = 1; i < objc; i++) {
(*argvPtr)[i - 1] = TclGetString(objv[i]);
}
@@ -1323,7 +1367,7 @@ TclPreventAliasLoop(
* chain then we have a loop.
*/
- aliasPtr = (Alias *) cmdPtr->objClientData;
+ aliasPtr = cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
@@ -1357,6 +1401,8 @@ TclPreventAliasLoop(
Tcl_AppendResult(interp, "cannot define or rename alias \"",
Tcl_GetCommandName(cmdInterp, cmd),
"\": would create a loop", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "ALIASLOOP", NULL);
return TCL_ERROR;
}
@@ -1369,7 +1415,7 @@ TclPreventAliasLoop(
if (aliasCmdPtr->objProc != AliasObjCmd) {
return TCL_OK;
}
- nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
+ nextAliasPtr = aliasCmdPtr->objClientData;
}
/* NOTREACHED */
@@ -1412,8 +1458,7 @@ AliasCreate(
Tcl_Obj **prefv;
int isNew, i;
- aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
- + objc * sizeof(Tcl_Obj *)));
+ aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = masterInterp;
@@ -1431,9 +1476,15 @@ AliasCreate(
Tcl_Preserve(slaveInterp);
Tcl_Preserve(masterInterp);
+ if (slaveInterp == masterInterp) {
+ aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
+ TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
+ } else {
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
TclGetString(namePtr), AliasObjCmd, aliasPtr,
AliasObjCmdDeleteProc);
+ }
if (TclPreventAliasLoop(interp, slaveInterp,
aliasPtr->slaveCmd) != TCL_OK) {
@@ -1458,7 +1509,7 @@ AliasCreate(
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
- ckfree((char *) aliasPtr);
+ ckfree(aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
@@ -1476,7 +1527,7 @@ AliasCreate(
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
while (1) {
Tcl_Obj *newToken;
- char *string;
+ const char *string;
string = TclGetString(aliasPtr->token);
hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew);
@@ -1515,11 +1566,11 @@ AliasCreate(
* interp alias {} foo {} zop # Now recreate "foo"...
*/
- targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
+ targetPtr = ckalloc(sizeof(Target));
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
- masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master;
+ masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
targetPtr->nextPtr = masterPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (masterPtr->targetsPtr != NULL) {
@@ -1688,6 +1739,70 @@ AliasList(
*/
static int
+AliasNRCmd(
+ ClientData clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Alias *aliasPtr = clientData;
+ int prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ Tcl_Obj *listPtr;
+ List *listRep;
+ int flags = TCL_EVAL_INVOKE;
+
+ /*
+ * Append the arguments to the command prefix and invoke the command in
+ * the target interp's global namespace.
+ */
+
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+
+ listPtr = Tcl_NewListObj(cmdc, NULL);
+ listRep = listPtr->internalRep.twoPtrValue.ptr1;
+ listRep->elemCount = cmdc;
+ cmdv = &listRep->elements;
+
+ prefv = &aliasPtr->objPtr;
+ memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
+ memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_IncrRefCount(cmdv[i]);
+ }
+
+ /*
+ * Use the ensemble rewriting machinery to ensure correct error messages:
+ * only the source command should show, not the full target prefix.
+ */
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 1;
+ iPtr->ensembleRewrite.numInsertedObjs = prefc;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += prefc - 1;
+ }
+
+ /*
+ * We are sending a 0-refCount obj, do not need a callback: it will be
+ * cleaned up automatically. But we may need to clear the rootEnsemble
+ * stuff ...
+ */
+
+ if (isRootEnsemble) {
+ TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+ iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ return Tcl_NREvalObj(interp, listPtr, flags);
+}
+
+static int
AliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -1714,7 +1829,7 @@ AliasObjCmd(
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
- cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*));
+ cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
prefv = &aliasPtr->objPtr;
@@ -1773,7 +1888,7 @@ AliasObjCmd(
*/
if (targetInterp != interp) {
- TclTransferResult(targetInterp, result, interp);
+ Tcl_TransferResult(targetInterp, result, interp);
Tcl_Release(targetInterp);
}
@@ -1838,8 +1953,8 @@ AliasObjCmdDeleteProc(
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
- ckfree((char *) targetPtr);
- ckfree((char *) aliasPtr);
+ ckfree(targetPtr);
+ ckfree(aliasPtr);
}
/*
@@ -1944,6 +2059,72 @@ Tcl_GetMaster(
/*
*----------------------------------------------------------------------
*
+ * TclSetSlaveCancelFlags --
+ *
+ * This function marks all slave interpreters belonging to a given
+ * interpreter as being canceled or not canceled, depending on the
+ * provided flags.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetSlaveCancelFlags(
+ Tcl_Interp *interp, /* Set cancel flags of this interpreter. */
+ int flags, /* Collection of OR-ed bits that control
+ * the cancellation of the script. Only
+ * TCL_CANCEL_UNWIND is currently
+ * supported. */
+ int force) /* Non-zero to ignore numLevels for the purpose
+ * of resetting the cancellation flags. */
+{
+ Master *masterPtr; /* Master record of given interpreter. */
+ Tcl_HashEntry *hPtr; /* Search element. */
+ Tcl_HashSearch hashSearch; /* Search variable. */
+ Slave *slavePtr; /* Slave record of interpreter. */
+ Interp *iPtr;
+
+ if (interp == NULL) {
+ return;
+ }
+
+ flags &= (CANCELED | TCL_CANCEL_UNWIND);
+
+ masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master;
+
+ hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
+ for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
+ slavePtr = Tcl_GetHashValue(hPtr);
+ iPtr = (Interp *) slavePtr->slaveInterp;
+
+ if (iPtr == NULL) {
+ continue;
+ }
+
+ if (flags == 0) {
+ TclResetCancellation((Tcl_Interp *) iPtr, force);
+ } else {
+ TclSetCancelFlags(iPtr, flags);
+ }
+
+ /*
+ * Now, recursively handle this for the slaves of this slave
+ * interpreter.
+ */
+
+ TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetInterpPath --
*
* Sets the result of the asking interpreter to a proper Tcl list
@@ -2077,6 +2258,8 @@ SlaveBgerror(
|| (length < 1)) {
Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BGERRORFORMAT", NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(slaveInterp, objv[0]);
@@ -2114,7 +2297,7 @@ SlaveCreate(
Slave *slavePtr;
InterpInfo *masterInfoPtr;
Tcl_HashEntry *hPtr;
- char *path;
+ const char *path;
int isNew, objc;
Tcl_Obj **objv;
@@ -2212,7 +2395,7 @@ SlaveCreate(
return slaveInterp;
error:
- TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
error2:
Tcl_DeleteInterp(slaveInterp);
@@ -2245,15 +2428,17 @@ SlaveObjCmd(
{
Tcl_Interp *slaveInterp = clientData;
int index;
- static const char *options[] = {
- "alias", "aliases", "bgerror", "debug", "eval",
- "expose", "hide", "hidden", "issafe",
- "invokehidden", "limit", "marktrusted", "recursionlimit", NULL
+ static const char *const options[] = {
+ "alias", "aliases", "bgerror", "debug",
+ "eval", "expose", "hide", "hidden",
+ "issafe", "invokehidden", "limit", "marktrusted",
+ "recursionlimit", NULL
};
enum options {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL,
- OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
- OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG,
+ OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN,
+ OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED,
+ OPT_RECLIMIT
};
if (slaveInterp == NULL) {
@@ -2284,7 +2469,7 @@ SlaveObjCmd(
objv[3], objc - 4, objv + 4);
}
}
- Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?");
+ Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
return TCL_ERROR;
case OPT_ALIASES:
if (objc != 2) {
@@ -2300,7 +2485,7 @@ SlaveObjCmd(
return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
case OPT_DEBUG:
/*
- * TIP #378 *
+ * TIP #378
* Currently only -frame supported, otherwise ?-option ?value? ...?
*/
if (objc > 4) {
@@ -2340,9 +2525,9 @@ SlaveObjCmd(
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
return TCL_OK;
case OPT_INVOKEHIDDEN: {
- int i, index;
+ int i;
const char *namespaceName;
- static const char *hiddenOptions[] = {
+ static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
enum hiddenOption {
@@ -2380,7 +2565,7 @@ SlaveObjCmd(
objc - i, objv + i);
}
case OPT_LIMIT: {
- static const char *limitTypes[] = {
+ static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
@@ -2389,7 +2574,7 @@ SlaveObjCmd(
int limitType;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?");
+ Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
@@ -2479,7 +2664,7 @@ SlaveObjCmdDeleteProc(
* A standard Tcl result.
*
* Side effects:
- * May modify INTERP_DEBUG flag in the slave.
+ * May modify INTERP_DEBUG_FRAME flag in the slave.
*
*----------------------------------------------------------------------
*/
@@ -2492,7 +2677,7 @@ SlaveDebugCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *debugTypes[] = {
+ static const char *const debugTypes[] = {
"-frame", NULL
};
enum DebugTypes {
@@ -2511,8 +2696,8 @@ SlaveDebugCmd(
Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
Tcl_SetObjResult(interp, resultPtr);
} else {
- if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes,
- "debug option", 0, &debugType) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
+ 0, &debugType) != TCL_OK) {
return TCL_ERROR;
}
if (debugType == DEBUG_TYPE_FRAME) {
@@ -2521,11 +2706,13 @@ SlaveDebugCmd(
!= TCL_OK) {
return TCL_ERROR;
}
+
/*
- * Quietly ignore attempts to disable interp debugging.
- * This is a one-way switch as frame debug info is maintained
- * in a stack that must be consistent once turned on.
+ * Quietly ignore attempts to disable interp debugging. This
+ * is a one-way switch as frame debug info is maintained in a
+ * stack that must be consistent once turned on.
*/
+
if (debugType) {
iPtr->flags |= INTERP_DEBUG_FRAME;
}
@@ -2562,7 +2749,16 @@ SlaveEval(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
- Tcl_Obj *objPtr;
+
+ /*
+ * TIP #285: If necessary, reset the cancellation flags for the slave
+ * interpreter now; otherwise, canceling a script in a master interpreter
+ * can result in a situation where a slave interpreter can no longer
+ * evaluate any scripts unless somebody calls the TclResetCancellation
+ * function for that particular Tcl_Interp.
+ */
+
+ TclSetSlaveCancelFlags(slaveInterp, 0, 0);
Tcl_Preserve(slaveInterp);
Tcl_AllowExceptions(slaveInterp);
@@ -2572,19 +2768,20 @@ SlaveEval(
* TIP #280: Make actual argument location available to eval'd script.
*/
- Interp *iPtr = (Interp *) interp;
- CmdFrame* invoker = iPtr->cmdFramePtr;
- int word = 0;
+ Interp *iPtr = (Interp *) interp;
+ CmdFrame *invoker = iPtr->cmdFramePtr;
+ int word = 0;
+
+ TclArgumentGet(interp, objv[0], &invoker, &word);
- TclArgumentGet (interp, objv[0], &invoker, &word);
result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
} else {
- objPtr = Tcl_ConcatObj(objc, objv);
+ Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
- TclTransferResult(slaveInterp, result, interp);
+ Tcl_TransferResult(slaveInterp, result, interp);
Tcl_Release(slaveInterp);
return result;
@@ -2614,19 +2811,21 @@ SlaveExpose(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
- char *name;
+ const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot expose commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]),
name) != TCL_OK) {
- TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
@@ -2663,6 +2862,8 @@ SlaveRecursionLimit(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "permission denied: "
"safe interpreters cannot change recursion limit", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
@@ -2671,6 +2872,8 @@ SlaveRecursionLimit(
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
+ NULL);
return TCL_ERROR;
}
Tcl_SetRecursionLimit(slaveInterp, limit);
@@ -2678,6 +2881,7 @@ SlaveRecursionLimit(
if (interp == slaveInterp && iPtr->numLevels > limit) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"falling back due to new recursion limit", -1));
+ Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
@@ -2713,18 +2917,20 @@ SlaveHide(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
- char *name;
+ const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot hide commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) {
- TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
@@ -2801,6 +3007,8 @@ SlaveInvokeHidden(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not allowed to invoke hidden commands from safe interpreter",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -2818,11 +3026,11 @@ SlaveInvokeHidden(
| TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if (result == TCL_OK) {
result = TclObjInvokeNamespace(slaveInterp, objc, objv,
- (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN);
+ (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
}
}
- TclTransferResult(slaveInterp, result, interp);
+ Tcl_TransferResult(slaveInterp, result, interp);
Tcl_Release(slaveInterp);
return result;
@@ -2855,6 +3063,8 @@ SlaveMarkTrusted(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot mark trusted",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
@@ -3112,6 +3322,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "command count limit exceeded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -3137,6 +3348,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "time limit exceeded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -3189,7 +3401,7 @@ RunLimitHandlers(
*/
handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
- (handlerPtr->handlerProc)(handlerPtr->clientData, interp);
+ handlerPtr->handlerProc(handlerPtr->clientData, interp);
handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;
/*
@@ -3210,9 +3422,9 @@ RunLimitHandlers(
if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
if (handlerPtr->deleteProc != NULL) {
- (handlerPtr->deleteProc)(handlerPtr->clientData);
+ handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
}
@@ -3259,7 +3471,7 @@ Tcl_LimitAddHandler(
* Allocate a handler record.
*/
- handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler));
+ handlerPtr = ckalloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
@@ -3376,9 +3588,9 @@ Tcl_LimitRemoveHandler(
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
- (handlerPtr->deleteProc)(handlerPtr->clientData);
+ handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
return;
}
@@ -3436,9 +3648,9 @@ TclLimitRemoveAllHandlers(
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
- (handlerPtr->deleteProc)(handlerPtr->clientData);
+ handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
@@ -3469,9 +3681,9 @@ TclLimitRemoveAllHandlers(
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
- (handlerPtr->deleteProc)(handlerPtr->clientData);
+ handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
@@ -3734,7 +3946,7 @@ TimeLimitCallback(
code = Tcl_LimitCheck(interp);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (while waiting for event)");
- TclBackgroundException(interp, code);
+ Tcl_BackgroundException(interp, code);
}
Tcl_Release(interp);
}
@@ -3866,7 +4078,7 @@ DeleteScriptLimitCallback(
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
- ckfree((char *) limitCBPtr);
+ ckfree(limitCBPtr);
}
/*
@@ -3902,7 +4114,7 @@ CallScriptLimitCallback(
code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
TCL_EVAL_GLOBAL);
if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) {
- TclBackgroundException(limitCBPtr->interp, code);
+ Tcl_BackgroundException(limitCBPtr->interp, code);
}
Tcl_Release(limitCBPtr->interp);
}
@@ -3957,7 +4169,7 @@ SetScriptLimitCallback(
return;
}
- hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key,
+ hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
limitCBPtr = Tcl_GetHashValue(hashPtr);
@@ -3966,7 +4178,7 @@ SetScriptLimitCallback(
limitCBPtr);
}
- limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback));
+ limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
@@ -4121,7 +4333,7 @@ SlaveCommandLimitCmd(
int objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *options[] = {
+ static const char *const options[] = {
"-command", "-granularity", "-value", NULL
};
enum Options {
@@ -4202,8 +4414,7 @@ SlaveCommandLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option? ?value? ?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, limitLen = 0;
@@ -4228,6 +4439,8 @@ SlaveCommandLimitCmd(
if (gran < 1) {
Tcl_AppendResult(interp, "granularity must be at "
"least 1", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4243,6 +4456,8 @@ SlaveCommandLimitCmd(
if (limit < 0) {
Tcl_AppendResult(interp, "command limit value must be at "
"least 0", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4292,7 +4507,7 @@ SlaveTimeLimitCmd(
int objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *options[] = {
+ static const char *const options[] = {
"-command", "-granularity", "-milliseconds", "-seconds", NULL
};
enum Options {
@@ -4390,8 +4605,7 @@ SlaveTimeLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option? ?value? ?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, milliLen = 0, secLen = 0;
@@ -4420,6 +4634,8 @@ SlaveTimeLimitCmd(
if (gran < 1) {
Tcl_AppendResult(interp, "granularity must be at "
"least 1", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4435,6 +4651,8 @@ SlaveTimeLimitCmd(
if (tmp < 0) {
Tcl_AppendResult(interp, "milliseconds must be at least 0",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.usec = ((long)tmp)*1000;
@@ -4451,6 +4669,8 @@ SlaveTimeLimitCmd(
if (tmp < 0) {
Tcl_AppendResult(interp, "seconds must be at least 0",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.sec = tmp;
@@ -4467,11 +4687,15 @@ SlaveTimeLimitCmd(
if (secObj != NULL && secLen == 0 && milliLen > 0) {
Tcl_AppendResult(interp, "may only set -milliseconds "
"if -seconds is not also being reset", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADUSAGE", NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
Tcl_AppendResult(interp, "may only reset -milliseconds "
"if -seconds is also being reset", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADUSAGE", NULL);
return TCL_ERROR;
}
}
diff --git a/generic/tclLink.c b/generic/tclLink.c
index df8b16a..00010f3 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -65,7 +65,7 @@ typedef struct Link {
*/
static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
- CONST char *name1, CONST char *name2, int flags);
+ const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
/*
@@ -102,7 +102,7 @@ static Tcl_Obj * ObjValue(Link *linkPtr);
int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
- CONST char *varName, /* Name of a global variable in interp. */
+ const char *varName, /* Name of a global variable in interp. */
char *addr, /* Address of a C variable to be linked to
* varName. */
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
@@ -112,7 +112,7 @@ Tcl_LinkVar(
Link *linkPtr;
int code;
- linkPtr = (Link *) ckalloc(sizeof(Link));
+ linkPtr = ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
@@ -127,15 +127,14 @@ Tcl_LinkVar(
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ ckfree(linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
- |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
- (ClientData) linkPtr);
+ |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ ckfree(linkPtr);
}
return code;
}
@@ -161,20 +160,19 @@ Tcl_LinkVar(
void
Tcl_UnlinkVar(
Tcl_Interp *interp, /* Interpreter containing variable to unlink */
- CONST char *varName) /* Global variable in interp to unlink. */
+ const char *varName) /* Global variable in interp to unlink. */
{
- Link *linkPtr;
+ Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName,
+ TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
- linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
- LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar(interp, varName,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- LinkTraceProc, (ClientData) linkPtr);
+ LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ ckfree(linkPtr);
}
/*
@@ -199,13 +197,12 @@ Tcl_UnlinkVar(
void
Tcl_UpdateLinkedVar(
Tcl_Interp *interp, /* Interpreter containing variable. */
- CONST char *varName) /* Name of global variable that is linked. */
+ const char *varName) /* Name of global variable that is linked. */
{
- Link *linkPtr;
+ Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName,
+ TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
int savedFlag;
- linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
- LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
@@ -217,7 +214,7 @@ Tcl_UpdateLinkedVar(
* Callback may have unlinked the variable. [Bug 1740631]
*/
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
- LinkTraceProc, (ClientData) NULL);
+ LinkTraceProc, NULL);
if (linkPtr != NULL) {
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
@@ -248,13 +245,13 @@ static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
- CONST char *name1, /* First part of variable name. */
- CONST char *name2, /* Second part of variable name. */
+ const char *name1, /* First part of variable name. */
+ const char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
- Link *linkPtr = (Link *) clientData;
+ Link *linkPtr = clientData;
int changed, valueLength;
- CONST char *value;
+ const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
@@ -269,13 +266,13 @@ LinkTraceProc(
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ ckfree(linkPtr);
} 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_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
- |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
+ |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
}
return NULL;
}
@@ -338,7 +335,7 @@ LinkTraceProc(
changed = 1;
break;
default:
- return "internal error: bad linked variable type";
+ return (char *) "internal error: bad linked variable type";
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -359,7 +356,7 @@ LinkTraceProc(
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "linked variable is read-only";
+ return (char *) "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
@@ -367,7 +364,7 @@ LinkTraceProc(
* This shouldn't ever happen.
*/
- return "internal error: linked variable couldn't be read";
+ return (char *) "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
@@ -376,7 +373,7 @@ LinkTraceProc(
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have integer value";
+ return (char *) "variable must have integer value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
@@ -386,7 +383,7 @@ LinkTraceProc(
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have integer value";
+ return (char *) "variable must have integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
@@ -399,7 +396,7 @@ LinkTraceProc(
#endif
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
- return "variable must have real value";
+ return (char *) "variable must have real value";
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
@@ -413,7 +410,7 @@ LinkTraceProc(
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have boolean value";
+ return (char *) "variable must have boolean value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
@@ -423,7 +420,7 @@ LinkTraceProc(
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have char value";
+ return (char *) "variable must have char value";
}
linkPtr->lastValue.c = (char)valueInt;
LinkedVar(char) = linkPtr->lastValue.c;
@@ -434,7 +431,7 @@ LinkTraceProc(
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have unsigned char value";
+ return (char *) "variable must have unsigned char value";
}
linkPtr->lastValue.uc = (unsigned char) valueInt;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
@@ -445,7 +442,7 @@ LinkTraceProc(
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have short value";
+ return (char *) "variable must have short value";
}
linkPtr->lastValue.s = (short)valueInt;
LinkedVar(short) = linkPtr->lastValue.s;
@@ -456,7 +453,7 @@ LinkTraceProc(
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have unsigned short value";
+ return (char *) "variable must have unsigned short value";
}
linkPtr->lastValue.us = (unsigned short)valueInt;
LinkedVar(unsigned short) = linkPtr->lastValue.us;
@@ -467,7 +464,7 @@ LinkTraceProc(
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have unsigned int value";
+ return (char *) "variable must have unsigned int value";
}
linkPtr->lastValue.ui = (unsigned int)valueWide;
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
@@ -478,7 +475,7 @@ LinkTraceProc(
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have long value";
+ return (char *) "variable must have long value";
}
linkPtr->lastValue.l = (long)valueWide;
LinkedVar(long) = linkPtr->lastValue.l;
@@ -489,7 +486,7 @@ LinkTraceProc(
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have unsigned long value";
+ return (char *) "variable must have unsigned long value";
}
linkPtr->lastValue.ul = (unsigned long)valueWide;
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
@@ -502,7 +499,7 @@ LinkTraceProc(
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have unsigned wide int value";
+ return (char *) "variable must have unsigned wide int value";
}
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
@@ -513,7 +510,7 @@ LinkTraceProc(
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have float value";
+ return (char *) "variable must have float value";
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
@@ -529,7 +526,7 @@ LinkTraceProc(
break;
default:
- return "internal error: bad linked variable type";
+ return (char *) "internal error: bad linked variable type";
}
return NULL;
}
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index d3465b0..9437f7e 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -18,8 +18,8 @@
*/
static List * AttemptNewList(Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
-static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[], int p);
+ Tcl_Obj *const objv[]);
+static List * NewListIntRep(int objc, Tcl_Obj *const objv[], int p);
static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeListInternalRep(Tcl_Obj *listPtr);
static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -38,7 +38,7 @@ static void UpdateStringOfList(Tcl_Obj *listPtr);
* storage to avoid an auxiliary stack.
*/
-Tcl_ObjType tclListType = {
+const Tcl_ObjType tclListType = {
"list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
@@ -72,7 +72,7 @@ Tcl_ObjType tclListType = {
static List *
NewListIntRep(
int objc,
- Tcl_Obj *CONST objv[],
+ Tcl_Obj *const objv[],
int p)
{
List *listRepPtr;
@@ -96,8 +96,7 @@ NewListIntRep(
return NULL;
}
- listRepPtr = (List *)
- attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)));
+ listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*)));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
@@ -166,6 +165,7 @@ AttemptNewList(
"list creation failed: unable to alloc %u bytes",
(unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))));
}
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return listRepPtr;
}
@@ -202,7 +202,7 @@ AttemptNewList(
Tcl_Obj *
Tcl_NewListObj(
int objc, /* Count of objects referenced by objv. */
- Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */
+ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
return Tcl_DbNewListObj(objc, objv, "unknown", 0);
}
@@ -212,7 +212,7 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_NewListObj(
int objc, /* Count of objects referenced by objv. */
- Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */
+ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
List *listRepPtr;
Tcl_Obj *listPtr;
@@ -273,8 +273,8 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
- Tcl_Obj *CONST objv[], /* An array of pointers to Tcl objects. */
- CONST char *file, /* The name of the source file calling this
+ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -309,8 +309,8 @@ Tcl_DbNewListObj(
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
- Tcl_Obj *CONST objv[], /* An array of pointers to Tcl objects. */
- CONST char *file, /* The name of the source file calling this
+ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -345,7 +345,7 @@ void
Tcl_SetListObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
int objc, /* Count of objects referenced by objv. */
- Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */
+ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
List *listRepPtr;
@@ -358,7 +358,6 @@ Tcl_SetListObj(
*/
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
Tcl_InvalidateStringRep(objPtr);
/*
@@ -636,12 +635,11 @@ Tcl_ListObjAppendElement(
listRepPtr->elemCount = numElems;
listRepPtr->refCount++;
oldListRepPtr->refCount--;
- listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
} else if (newSize) {
- listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize);
+ listRepPtr = ckrealloc(listRepPtr, newSize);
listRepPtr->maxElemCount = newMax;
- listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
}
+ listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
/*
* Add objPtr to the end of listPtr's array of element pointers. Increment
@@ -817,7 +815,7 @@ Tcl_ListObjReplace(
int first, /* Index of first element to replace. */
int count, /* Number of elements to replace. */
int objc, /* Number of objects to insert. */
- Tcl_Obj *CONST objv[]) /* An array of objc pointers to Tcl objects to
+ Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to
* insert. */
{
List *listRepPtr;
@@ -925,7 +923,7 @@ Tcl_ListObjReplace(
return TCL_ERROR;
}
- listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
listRepPtr->refCount++;
elemPtrs = &listRepPtr->elements;
@@ -979,7 +977,7 @@ Tcl_ListObjReplace(
(size_t) numAfterLast * sizeof(Tcl_Obj *));
}
- ckfree((char *) oldListRepPtr);
+ ckfree(oldListRepPtr);
}
}
@@ -1128,8 +1126,8 @@ TclLindexFlat(
Tcl_IncrRefCount(listPtr);
for (i=0 ; i<indexCount && listPtr ; i++) {
- int index, listLen;
- Tcl_Obj **elemPtrs, *sublistCopy;
+ int index, listLen = 0;
+ Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
* Here we make a private copy of the current sublist, so we avoid any
@@ -1214,8 +1212,8 @@ TclLsetList(
Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
{
- int indexCount; /* Number of indices in the index list. */
- Tcl_Obj **indices; /* Vector of indices in the index list. */
+ int indexCount = 0; /* Number of indices in the index list. */
+ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
int index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
@@ -1266,8 +1264,8 @@ TclLsetList(
*
* Results:
* Returns the new value of the list variable, or NULL if an error
- * occurred. The returned object includes one reference count for
- * the pointer returned.
+ * occurred. The returned object includes one reference count for the
+ * pointer returned.
*
* Side effects:
* On entry, the reference count of the variable value does not reflect
@@ -1309,12 +1307,12 @@ TclLsetFlat(
/* Index args. */
Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
{
- int index, result;
+ int index, result, len;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
/*
- * If there are no indices, simply return the new value.
- * (Without indices, [lset] is a synonym for [set].
+ * If there are no indices, simply return the new value. (Without
+ * indices, [lset] is a synonym for [set].
*/
if (indexCount == 0) {
@@ -1323,14 +1321,14 @@ TclLsetFlat(
}
/*
- * If the list is shared, make a copy we can modify (copy-on-write).
- * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few
- * reasons: 1) we have not yet confirmed listPtr is actually a list;
- * 2) We make a verbatim copy of any existing string rep, and when
- * we combine that with the delayed invalidation of string reps of
- * modified Tcl_Obj's implemented below, the outcome is that any
- * error condition that causes this routine to return NULL, will
- * leave the string rep of listPtr and all elements to be unchanged.
+ * If the list is shared, make a copy we can modify (copy-on-write). We
+ * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
+ * 1) we have not yet confirmed listPtr is actually a list; 2) We make a
+ * verbatim copy of any existing string rep, and when we combine that with
+ * the delayed invalidation of string reps of modified Tcl_Obj's
+ * implemented below, the outcome is that any error condition that causes
+ * this routine to return NULL, will leave the string rep of listPtr and
+ * all elements to be unchanged.
*/
subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
@@ -1344,8 +1342,8 @@ TclLsetFlat(
chainPtr = NULL;
/*
- * Loop through all the index arguments, and for each one dive
- * into the appropriate sublist.
+ * Loop through all the index arguments, and for each one dive into the
+ * appropriate sublist.
*/
do {
@@ -1364,7 +1362,7 @@ TclLsetFlat(
* WARNING: the macro TclGetIntForIndexM is not safe for
* post-increments, avoid '*indexArray++' here.
*/
-
+
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
!= TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
@@ -1373,24 +1371,30 @@ TclLsetFlat(
}
indexArray++;
- if (index < 0 || index >= elemCount) {
+ if (index < 0 || index > elemCount) {
/* ...the index points outside the sublist. */
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
break;
}
/*
- * No error conditions. As long as we're not yet on the last
- * index, determine the next sublist for the next pass through
- * the loop, and take steps to make sure it is an unshared copy,
- * as we intend to modify it.
+ * No error conditions. As long as we're not yet on the last index,
+ * determine the next sublist for the next pass through the loop, and
+ * take steps to make sure it is an unshared copy, as we intend to
+ * modify it.
*/
result = TCL_OK;
if (--indexCount) {
parentList = subListPtr;
- subListPtr = elemPtrs[index];
+ if (index == elemCount) {
+ subListPtr = Tcl_NewObj();
+ } else {
+ subListPtr = elemPtrs[index];
+ }
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
}
@@ -1400,73 +1404,88 @@ TclLsetFlat(
* we know to be unshared. This call will also deal with the
* situation where parentList shares its intrep with other
* Tcl_Obj's. Dealing with the shared intrep case can cause
- * subListPtr to become shared again, so detect that case and
- * make and store another copy.
+ * subListPtr to become shared again, so detect that case and make
+ * and store another copy.
*/
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ if (index == elemCount) {
+ Tcl_ListObjAppendElement(NULL, parentList, subListPtr);
+ } else {
+ TclListObjSetElement(NULL, parentList, index, subListPtr);
+ }
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
TclListObjSetElement(NULL, parentList, index, subListPtr);
}
/*
- * The TclListObjSetElement() calls do not spoil the string
- * rep of parentList, and that's fine for now, since all we've
- * done so far is replace a list element with an unshared copy.
- * The list value remains the same, so the string rep. is still
- * valid, and unchanged, which is good because if this whole
- * routine returns NULL, we'd like to leave no change to the
- * value of the lset variable. Later on, when we set valuePtr
- * in its proper place, then all containing lists will have
- * their values changed, and will need their string reps spoiled.
- * We maintain a list of all those Tcl_Obj's (via a little intrep
- * surgery) so we can spoil them at that time.
+ * The TclListObjSetElement() calls do not spoil the string rep of
+ * parentList, and that's fine for now, since all we've done so
+ * far is replace a list element with an unshared copy. The list
+ * value remains the same, so the string rep. is still valid, and
+ * unchanged, which is good because if this whole routine returns
+ * NULL, we'd like to leave no change to the value of the lset
+ * variable. Later on, when we set valuePtr in its proper place,
+ * then all containing lists will have their values changed, and
+ * will need their string reps spoiled. We maintain a list of all
+ * those Tcl_Obj's (via a little intrep surgery) so we can spoil
+ * them at that time.
*/
- parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr;
+ parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
chainPtr = parentList;
}
} while (indexCount > 0);
/*
- * Either we've detected and error condition, and exited the loop
- * with result == TCL_ERROR, or we've successfully reached the last
- * index, and we're ready to store valuePtr. In either case, we
- * need to clean up our string spoiling list of Tcl_Obj's.
+ * Either we've detected and error condition, and exited the loop with
+ * result == TCL_ERROR, or we've successfully reached the last index, and
+ * we're ready to store valuePtr. In either case, we need to clean up our
+ * string spoiling list of Tcl_Obj's.
*/
while (chainPtr) {
Tcl_Obj *objPtr = chainPtr;
if (result == TCL_OK) {
-
/*
- * We're going to store valuePtr, so spoil string reps
- * of all containing lists.
+ * We're going to store valuePtr, so spoil string reps of all
+ * containing lists.
*/
Tcl_InvalidateStringRep(objPtr);
}
- /* Clear away our intrep surgery mess */
- chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+ /*
+ * Clear away our intrep surgery mess.
+ */
+
+ chainPtr = objPtr->internalRep.twoPtrValue.ptr2;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
if (result != TCL_OK) {
- /*
- * Error return; message is already in interp. Clean up
- * any excess memory.
+ /*
+ * Error return; message is already in interp. Clean up any excess
+ * memory.
*/
+
if (retValuePtr != listPtr) {
Tcl_DecrRefCount(retValuePtr);
}
return NULL;
}
- /* Store valuePtr in proper sublist and return */
- TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ /*
+ * Store valuePtr in proper sublist and return.
+ */
+
+ Tcl_ListObjLength(NULL, subListPtr, &len);
+ if (index == len) {
+ Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
+ } else {
+ TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ }
Tcl_InvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
@@ -1530,6 +1549,8 @@ TclListObjSetElement(
if (!length) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
@@ -1550,6 +1571,8 @@ TclListObjSetElement(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
}
return TCL_ERROR;
}
@@ -1575,7 +1598,7 @@ TclListObjSetElement(
}
listRepPtr->refCount++;
listRepPtr->elemCount = elemCount;
- listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
oldListRepPtr->refCount--;
}
@@ -1632,7 +1655,7 @@ FreeListInternalRep(
for (i = 0; i < numElems; i++) {
Tcl_DecrRefCount(elemPtrs[i]);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRepPtr);
}
listPtr->internalRep.twoPtrValue.ptr1 = NULL;
@@ -1691,7 +1714,8 @@ SetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
- char *string, *s;
+ const char *string;
+ char *s;
const char *elemStart, *nextElem;
int lenRemain, length, estCount, elemSize, hasBrace, i, j, result;
const char *limit; /* Points just after string's last byte. */
@@ -1790,7 +1814,10 @@ SetListFromAny(
elemPtr = elemPtrs[j];
Tcl_DecrRefCount(elemPtr);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRepPtr);
+ if (interp != NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL);
+ }
return result;
}
if (elemStart >= limit) {
@@ -1805,7 +1832,7 @@ SetListFromAny(
* "elemSize" bytes starting at "elemStart".
*/
- s = ckalloc((unsigned) elemSize + 1);
+ s = ckalloc(elemSize + 1);
if (hasBrace) {
memcpy(s, elemStart, (size_t) elemSize);
s[elemSize] = 0;
@@ -1864,7 +1891,8 @@ UpdateStringOfList(
List *listRepPtr = ListRepPtr(listPtr);
int numElems = listRepPtr->elemCount;
register int i;
- char *elem, *dst;
+ const char *elem;
+ char *dst;
int length;
Tcl_Obj **elemPtrs;
@@ -1880,7 +1908,7 @@ UpdateStringOfList(
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int));
+ flagPtr = ckalloc(numElems * sizeof(int));
}
listPtr->length = 1;
elemPtrs = &listRepPtr->elements;
@@ -1901,7 +1929,7 @@ UpdateStringOfList(
* Pass 2: copy into string rep buffer.
*/
- listPtr->bytes = ckalloc((unsigned) listPtr->length);
+ listPtr->bytes = ckalloc(listPtr->length);
dst = listPtr->bytes;
for (i = 0; i < numElems; i++) {
elem = TclGetStringFromObj(elemPtrs[i], &length);
@@ -1911,7 +1939,7 @@ UpdateStringOfList(
dst++;
}
if (flagPtr != localFlags) {
- ckfree((char *) flagPtr);
+ ckfree(flagPtr);
}
if (dst == listPtr->bytes) {
*dst = 0;
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 62dc5c0..72c4577 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -31,7 +31,7 @@
static int AddLocalLiteralEntry(CompileEnv *envPtr,
Tcl_Obj *objPtr, int localHash);
static void ExpandLocalLiteralArray(CompileEnv *envPtr);
-static unsigned int HashString(const char *bytes, int length);
+static unsigned HashString(const char *string, int length);
static void RebuildLiteralTable(LiteralTable *tablePtr);
/*
@@ -59,7 +59,7 @@ TclInitLiteralTable(
* supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
- Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4",
+ Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable",
TCL_SMALL_HASH_TABLE);
#endif
@@ -97,12 +97,12 @@ TclCleanupLiteralTable(
* cleaned. */
{
int i;
- LiteralEntry* entryPtr; /* Pointer to the current entry in the hash
+ LiteralEntry *entryPtr; /* Pointer to the current entry in the hash
* table of literals. */
- LiteralEntry* nextPtr; /* Pointer to the next entry in the bucket. */
- Tcl_Obj* objPtr; /* Pointer to a literal object whose internal
+ LiteralEntry *nextPtr; /* Pointer to the next entry in the bucket. */
+ Tcl_Obj *objPtr; /* Pointer to a literal object whose internal
* rep is being freed. */
- const Tcl_ObjType* typePtr; /* Pointer to the object's type. */
+ const Tcl_ObjType *typePtr; /* Pointer to the object's type. */
int didOne; /* Flag for whether we've removed a literal in
* the current bucket. */
@@ -129,15 +129,15 @@ TclCleanupLiteralTable(
typePtr = objPtr->typePtr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
if (objPtr->bytes == NULL) {
- Tcl_Panic( "literal without a string rep" );
+ Tcl_Panic("%s: literal without a string rep",
+ "TclCleanupLiteralTable");
}
objPtr->typePtr = NULL;
typePtr->freeIntRepProc(objPtr);
didOne = 1;
break;
- } else {
- entryPtr = nextPtr;
}
+ entryPtr = nextPtr;
}
} while (didOne);
}
@@ -198,7 +198,7 @@ TclDeleteLiteralTable(
objPtr = entryPtr->objPtr;
TclDecrRefCount(objPtr);
nextPtr = entryPtr->nextPtr;
- ckfree((char *) entryPtr);
+ ckfree(entryPtr);
entryPtr = nextPtr;
}
}
@@ -208,7 +208,7 @@ TclDeleteLiteralTable(
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
- ckfree((char *) tablePtr->buckets);
+ ckfree(tablePtr->buckets);
}
}
@@ -220,20 +220,20 @@ TclDeleteLiteralTable(
* Find, or if necessary create, an object in the interpreter's literal
* table that has a string representation matching the argument
* string. If nsPtr!=NULL then only literals stored for the namespace are
- * considered.
+ * considered.
*
* Results:
* The literal object. If it was created in this call *newPtr is set to
- * 1, else 0. NULL is returned if newPtr==NULL and no literal is found.
+ * 1, else 0. NULL is returned if newPtr==NULL and no literal is found.
*
* Side effects:
- * Increments the ref count of the global LiteralEntry since the caller
- * now holds a reference.
- * If LITERAL_ON_HEAP is set in flags, this function is given ownership
- * of the string: if an object is created then its string representation
- * is set directly from string, otherwise the string is freed. Typically,
- * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
- * buffer holding the result of backslash substitutions.
+ * Increments the ref count of the global LiteralEntry since the caller
+ * now holds a reference. If LITERAL_ON_HEAP is set in flags, this
+ * function is given ownership of the string: if an object is created
+ * then its string representation is set directly from string, otherwise
+ * the string is freed. Typically, a caller sets LITERAL_ON_HEAP if
+ * "string" is an already heap-allocated buffer holding the result of
+ * backslash substitutions.
*
*----------------------------------------------------------------------
*/
@@ -241,24 +241,26 @@ TclDeleteLiteralTable(
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
- char *bytes,
- int length,
- unsigned int hash, /* The string's hash. If -1, it will be computed here */
+ char *bytes, /* The start of the string. Note that this is
+ * not a NUL-terminated string. */
+ int length, /* Number of bytes in the string. */
+ unsigned hash, /* The string's hash. If -1, it will be
+ * computed here. */
int *newPtr,
Namespace *nsPtr,
int flags,
LiteralEntry **globalPtrPtr)
{
- LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
int globalHash;
Tcl_Obj *objPtr;
-
+
/*
* Is it in the interpreter's global literal table?
*/
- if (hash == (unsigned int) -1) {
+ if (hash == (unsigned) -1) {
hash = HashString(bytes, length);
}
globalHash = (hash & globalTablePtr->mask);
@@ -309,12 +311,12 @@ TclCreateLiteral(
#ifdef TCL_COMPILE_DEBUG
if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
- Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
- (length>60? 60 : length), bytes);
+ Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
+ "TclRegisterLiteral", (length>60? 60 : length), bytes);
}
#endif
- globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
+ globalPtr = ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
@@ -347,8 +349,8 @@ TclCreateLiteral(
}
}
if (!found) {
- Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
- (length>60? 60 : length), bytes);
+ Tcl_Panic("%s: literal \"%.*s\" wasn't global",
+ "TclRegisterLiteral", (length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
@@ -406,15 +408,15 @@ TclRegisterLiteral(
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
* malloc'd bytes and ownership is passed to
- * this function. If LITERAL_NS_SCOPE then
- * the literal shouldnot be shared accross
+ * this function. If LITERAL_CMD_NAME then
+ * the literal should not be shared accross
* namespaces. */
{
Interp *iPtr = envPtr->iPtr;
- LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
- unsigned int hash;
+ unsigned hash;
int localHash, objIndex, new;
Namespace *nsPtr;
@@ -448,30 +450,35 @@ TclRegisterLiteral(
}
/*
- * The literal is new to this CompileEnv. Should it be shared accross
- * namespaces? If it is a fully qualified name, the namespace
- * specification is not needed to avoid sharing.
+ * The literal is new to this CompileEnv. If it is a command name, avoid
+ * sharing it accross namespaces, and try not to share it with non-cmd
+ * literals. Note that FQ command names can be shared, so that we register
+ * the namespace as the interp's global NS.
*/
- if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr
- && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) {
- nsPtr = iPtr->varFramePtr->nsPtr;
+ if (flags & LITERAL_CMD_NAME) {
+ if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
+ nsPtr = iPtr->globalNsPtr;
+ } else {
+ nsPtr = iPtr->varFramePtr->nsPtr;
+ }
} else {
nsPtr = NULL;
}
-
+
/*
* Is it in the interpreter's global literal table? If not, create it.
*/
- objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr,
- flags, &globalPtr);
+ objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
+ &globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
if (globalPtr->refCount < 1) {
- Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
- (length>60? 60 : length), bytes, globalPtr->refCount);
+ Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
+ "TclRegisterLiteral", (length>60? 60 : length), bytes,
+ globalPtr->refCount);
}
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
@@ -504,9 +511,9 @@ TclLookupLiteralEntry(
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
- LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ LiteralTable *globalTablePtr = &iPtr->literalTable;
register LiteralEntry *entryPtr;
- char *bytes;
+ const char *bytes;
int length, globalHash;
bytes = TclGetStringFromObj(objPtr, &length);
@@ -550,12 +557,12 @@ TclHideLiteral(
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
- LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ LiteralTable *localTablePtr = &envPtr->localLitTable;
int localHash, length;
- char *bytes;
+ const char *bytes;
Tcl_Obj *newObjPtr;
- lPtr = &(envPtr->literalArrayPtr[index]);
+ lPtr = &envPtr->literalArrayPtr[index];
/*
* To avoid unwanted sharing we need to copy the object and remove it from
@@ -623,7 +630,7 @@ TclAddLiteralObj(
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
- lPtr = &(envPtr->literalArrayPtr[objIndex]);
+ lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
lPtr->refCount = -1; /* i.e., unused */
@@ -649,7 +656,7 @@ TclAddLiteralObj(
*
* Side effects:
* Expands the literal array if necessary. May rebuild the hash bucket
- * array of the CompileEnv's literal array if it becomes too large.
+ * array of the CompileEnv's literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
@@ -658,10 +665,10 @@ static int
AddLocalLiteralEntry(
register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
- Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
+ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
int localHash) /* Hash value for the literal's string. */
{
- register LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ register LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
int objIndex;
@@ -702,8 +709,8 @@ AddLocalLiteralEntry(
if (!found) {
bytes = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
- (length>60? 60 : length), bytes);
+ Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
+ "AddLocalLiteralEntry", (length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
@@ -741,7 +748,7 @@ ExpandLocalLiteralArray(
* 0 and (envPtr->literalArrayNext - 1) [inclusive].
*/
- LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ LiteralTable *localTablePtr = &envPtr->localLitTable;
int currElems = envPtr->literalArrayNext;
size_t currBytes = (currElems * sizeof(LiteralEntry));
LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
@@ -749,14 +756,14 @@ ExpandLocalLiteralArray(
int i;
if (envPtr->mallocedLiteralArray) {
- newArrayPtr = (LiteralEntry *) ckrealloc(
- (char *)currArrayPtr, 2 * currBytes);
+ newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes);
} else {
/*
* envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
- * code a ckrealloc equivalent for ourselves
+ * code a ckrealloc equivalent for ourselves.
*/
- newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes);
+
+ newArrayPtr = ckalloc(2 * currBytes);
memcpy(newArrayPtr, currArrayPtr, currBytes);
envPtr->mallocedLiteralArray = 1;
}
@@ -768,7 +775,7 @@ ExpandLocalLiteralArray(
if (currArrayPtr != newArrayPtr) {
for (i=0 ; i<currElems ; i++) {
if (newArrayPtr[i].nextPtr != NULL) {
- newArrayPtr[i].nextPtr = newArrayPtr
+ newArrayPtr[i].nextPtr = newArrayPtr
+ (newArrayPtr[i].nextPtr - currArrayPtr);
}
}
@@ -814,9 +821,9 @@ TclReleaseLiteral(
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
- LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ LiteralTable *globalTablePtr = &iPtr->literalTable;
register LiteralEntry *entryPtr, *prevPtr;
- char *bytes;
+ const char *bytes;
int length, index;
bytes = TclGetStringFromObj(objPtr, &length);
@@ -845,7 +852,7 @@ TclReleaseLiteral(
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
- ckfree((char *) entryPtr);
+ ckfree(entryPtr);
globalTablePtr->numEntries--;
TclDecrRefCount(objPtr);
@@ -882,13 +889,12 @@ TclReleaseLiteral(
*----------------------------------------------------------------------
*/
-static unsigned int
+static unsigned
HashString(
- register const char *bytes, /* String for which to compute hash value. */
+ register const char *string, /* String for which to compute hash value. */
int length) /* Number of bytes in the string. */
{
- register unsigned int result;
- register int i;
+ register unsigned int result = 0;
/*
* I tried a zillion different hash functions and asked many other people
@@ -898,17 +904,33 @@ HashString(
* following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings, and
- * multiplying by 9 is just about as good.
+ * multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the hash value
- * for ever, plus they spread fairly rapidly up to the high-order bits
- * to fill out the hash value. This seems works well both for decimal
- * and non-decimal strings.
+ * character's bits hang around in the low-order bits of the hash value
+ * for ever, plus they spread fairly rapidly up to the high-order bits
+ * to fill out the hash value. This seems works well both for decimal
+ * and non-decimal strings.
+ *
+ * Note that this function is very weak against malicious strings; it's
+ * very easy to generate multiple keys that have the same hashcode. On the
+ * other hand, that hardly ever actually occurs and this function *is*
+ * very cheap, even by comparison with industry-standard hashes like FNV.
+ * If real strength of hash is required though, use a custom hash based on
+ * Bob Jenkins's lookup3(), but be aware that it's significantly slower.
+ * Tcl scripts tend to not have a big issue in this area, and literals
+ * mostly aren't looked up by name anyway.
+ *
+ * See also HashStringKey in tclHash.c.
+ * See also TclObjHashKey in tclObj.c.
+ *
+ * See [tcl-Feature Request #2958832]
*/
- result = 0;
- for (i=0 ; i<length ; i++) {
- result += (result<<3) + bytes[i];
+ if (length > 0) {
+ result = UCHAR(*string);
+ while (--length) {
+ result += (result << 3) + UCHAR(*++string);
+ }
}
return result;
}
@@ -940,7 +962,7 @@ RebuildLiteralTable(
register LiteralEntry **oldChainPtr, **newChainPtr;
register LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
- char *bytes;
+ const char *bytes;
int oldSize, count, index, length;
oldSize = tablePtr->numBuckets;
@@ -952,8 +974,7 @@ RebuildLiteralTable(
*/
tablePtr->numBuckets *= 4;
- tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
- (tablePtr->numBuckets * sizeof(LiteralEntry *)));
+ tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
@@ -971,7 +992,7 @@ RebuildLiteralTable(
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
- bucketPtr = &(tablePtr->buckets[index]);
+ bucketPtr = &tablePtr->buckets[index];
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
@@ -982,7 +1003,7 @@ RebuildLiteralTable(
*/
if (oldBuckets != tablePtr->staticBuckets) {
- ckfree((char *) oldBuckets);
+ ckfree(oldBuckets);
}
}
@@ -1044,7 +1065,7 @@ TclLiteralStats(
* Print out the histogram and a few other pieces of information.
*/
- result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+ result = ckalloc(NUM_COUNTERS*60 + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
@@ -1083,7 +1104,7 @@ TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
- register LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ register LiteralTable *localTablePtr = &envPtr->localLitTable;
register LiteralEntry *localPtr;
char *bytes;
register int i;
@@ -1096,23 +1117,27 @@ TclVerifyLocalLiteralTable(
count++;
if (localPtr->refCount != -1) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
+ Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
+ "TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
+ Tcl_Panic("%s: local literal \"%.*s\" is not global",
+ "TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes);
}
if (localPtr->objPtr->bytes == NULL) {
- Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
+ Tcl_Panic("%s: literal has NULL string rep",
+ "TclVerifyLocalLiteralTable");
}
}
}
if (count != localTablePtr->numEntries) {
- Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
- count, localTablePtr->numEntries);
+ Tcl_Panic("%s: local literal table had %d entries, should be %d",
+ "TclVerifyLocalLiteralTable", count,
+ localTablePtr->numEntries);
}
}
@@ -1137,7 +1162,7 @@ TclVerifyGlobalLiteralTable(
Interp *iPtr) /* Points to interpreter whose global literal
* table is to be validated. */
{
- register LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ register LiteralTable *globalTablePtr = &iPtr->literalTable;
register LiteralEntry *globalPtr;
char *bytes;
register int i;
@@ -1150,17 +1175,20 @@ TclVerifyGlobalLiteralTable(
count++;
if (globalPtr->refCount < 1) {
bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
- Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
+ Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
+ "TclVerifyGlobalLiteralTable",
(length>60? 60 : length), bytes, globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
- Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
+ Tcl_Panic("%s: literal has NULL string rep",
+ "TclVerifyGlobalLiteralTable");
}
}
}
if (count != globalTablePtr->numEntries) {
- Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
- count, globalTablePtr->numEntries);
+ Tcl_Panic("%s: global literal table had %d entries, should be %d",
+ "TclVerifyGlobalLiteralTable", count,
+ globalTablePtr->numEntries);
}
}
#endif /*TCL_COMPILE_DEBUG*/
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index e64d0e0..707d6ec 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -55,11 +55,6 @@ typedef struct LoadedPackage {
* in trusted interpreters. */
int safeInterpRefCount; /* How many times the package has been loaded
* in safe interpreters. */
- Tcl_FSUnloadFileProc *unLoadProcPtr;
- /* Function to use to unload this package. If
- * NULL, then we do not attempt to unload the
- * package. If fileName is NULL, then this
- * field is irrelevant. */
struct LoadedPackage *nextPtr;
/* Next in list of all packages loaded into
* this application process. NULL means end of
@@ -129,16 +124,14 @@ Tcl_LoadObjCmd(
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_DString unloadName, safeUnloadName;
- Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
- const char *symbols[4];
- Tcl_PackageInitProc **procPtrs[4];
- ClientData clientData;
- char *p, *fullFileName, *packageName;
+ const char *symbols[2];
+ Tcl_PackageInitProc *initProc;
+ const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
- Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
Tcl_UniChar ch;
+ unsigned len;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
@@ -167,6 +160,8 @@ Tcl_LoadObjCmd(
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -177,7 +172,7 @@ Tcl_LoadObjCmd(
target = interp;
if (objc == 4) {
- char *slaveIntName = Tcl_GetString(objv[3]);
+ const char *slaveIntName = Tcl_GetString(objv[3]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
@@ -233,6 +228,8 @@ Tcl_LoadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" is already loaded for package \"",
pkgPtr->packageName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "SPLITPERSONALITY", NULL);
code = TCL_ERROR;
Tcl_MutexUnlock(&packageMutex);
goto done;
@@ -250,8 +247,7 @@ Tcl_LoadObjCmd(
*/
if (pkgPtr != NULL) {
- ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
- "tclLoad", NULL);
+ ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
@@ -269,6 +265,8 @@ Tcl_LoadObjCmd(
if (fullFileName[0] == 0) {
Tcl_AppendResult(interp, "package \"", packageName,
"\" isn't loaded statically", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -288,10 +286,9 @@ Tcl_LoadObjCmd(
retc = TclGuessPackageName(fullFileName, &pkgName);
if (!retc) {
- Tcl_Obj *splitPtr;
- Tcl_Obj *pkgGuessPtr;
+ Tcl_Obj *splitPtr, *pkgGuessPtr;
int pElements;
- char *pkgGuess;
+ const char *pkgGuess;
/*
* The platform-specific code couldn't figure out the module
@@ -321,6 +318,8 @@ Tcl_LoadObjCmd(
Tcl_AppendResult(interp,
"couldn't figure out package name for ",
fullFileName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "WHATPACKAGE", NULL);
code = TCL_ERROR;
goto done;
}
@@ -358,50 +357,38 @@ Tcl_LoadObjCmd(
*/
symbols[0] = Tcl_DStringValue(&initName);
- symbols[1] = Tcl_DStringValue(&safeInitName);
- symbols[2] = Tcl_DStringValue(&unloadName);
- symbols[3] = Tcl_DStringValue(&safeUnloadName);
- procPtrs[0] = &initProc;
- procPtrs[1] = &safeInitProc;
- procPtrs[2] = &unloadProc;
- procPtrs[3] = &safeUnloadProc;
+ symbols[1] = NULL;
Tcl_MutexLock(&packageMutex);
- code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs,
- &loadHandle, &clientData, &unLoadProcPtr);
+ code = Tcl_LoadFile(interp, objv[1], symbols, 0, &initProc,
+ &loadHandle);
Tcl_MutexUnlock(&packageMutex);
- loadHandle = (Tcl_LoadHandle) clientData;
if (code != TCL_OK) {
goto done;
}
- if (*procPtrs[0] /* initProc */ == NULL) {
- Tcl_AppendResult(interp, "couldn't find procedure ",
- Tcl_DStringValue(&initName), NULL);
- if (unLoadProcPtr != NULL) {
- (*unLoadProcPtr)(loadHandle);
- }
- code = TCL_ERROR;
- goto done;
- }
-
/*
* Create a new record to describe this package.
*/
- pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned)
- (strlen(fullFileName) + 1));
- strcpy(pkgPtr->fileName, fullFileName);
- pkgPtr->packageName = (char *) ckalloc((unsigned)
- (Tcl_DStringLength(&pkgName) + 1));
- strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
+ pkgPtr = ckalloc(sizeof(LoadedPackage));
+ len = strlen(fullFileName) + 1;
+ pkgPtr->fileName = ckalloc(len);
+ memcpy(pkgPtr->fileName, fullFileName, len);
+ len = (unsigned) Tcl_DStringLength(&pkgName) + 1;
+ pkgPtr->packageName = ckalloc(len);
+ memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len);
pkgPtr->loadHandle = loadHandle;
- pkgPtr->unLoadProcPtr = unLoadProcPtr;
- pkgPtr->initProc = *procPtrs[0];
- pkgPtr->safeInitProc = *procPtrs[1];
- pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2];
- pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3];
+ pkgPtr->initProc = initProc;
+ pkgPtr->safeInitProc = (Tcl_PackageInitProc *)
+ Tcl_FindSymbol(interp, loadHandle,
+ Tcl_DStringValue(&safeInitName));
+ pkgPtr->unloadProc = (Tcl_PackageUnloadProc *)
+ Tcl_FindSymbol(interp, loadHandle,
+ Tcl_DStringValue(&unloadName));
+ pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *)
+ Tcl_FindSymbol(interp, loadHandle,
+ Tcl_DStringValue(&safeUnloadName));
pkgPtr->interpRefCount = 0;
pkgPtr->safeInterpRefCount = 0;
@@ -409,6 +396,13 @@ Tcl_LoadObjCmd(
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
+
+ /*
+ * The Tcl_FindSymbol calls may have left a spurious error message in
+ * the interpreter result.
+ */
+
+ Tcl_ResetResult(interp);
}
/*
@@ -417,17 +411,27 @@ Tcl_LoadObjCmd(
*/
if (Tcl_IsSafe(target)) {
- if (pkgPtr->safeInitProc != NULL) {
- code = (*pkgPtr->safeInitProc)(target);
- } else {
+ if (pkgPtr->safeInitProc == NULL) {
Tcl_AppendResult(interp,
"can't use package in a safe interpreter: no ",
pkgPtr->packageName, "_SafeInit procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
+ NULL);
code = TCL_ERROR;
goto done;
}
+ code = pkgPtr->safeInitProc(target);
} else {
- code = (*pkgPtr->initProc)(target);
+ if (pkgPtr->initProc == NULL) {
+ Tcl_AppendResult(interp,
+ "can't attach package to interpreter: no ",
+ pkgPtr->packageName, "_Init procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+ code = pkgPtr->initProc(target);
}
/*
@@ -442,9 +446,9 @@ Tcl_LoadObjCmd(
Tcl_MutexLock(&packageMutex);
if (Tcl_IsSafe(target)) {
- ++pkgPtr->safeInterpRefCount;
+ pkgPtr->safeInterpRefCount++;
} else {
- ++pkgPtr->interpRefCount;
+ pkgPtr->interpRefCount++;
}
Tcl_MutexUnlock(&packageMutex);
@@ -453,15 +457,13 @@ Tcl_LoadObjCmd(
* additional static packages at the head of the linked list!
*/
- ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
- "tclLoad", NULL);
- ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+ ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
- Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
- (ClientData) ipPtr);
+ Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
} else {
- TclTransferResult(target, code, interp);
+ Tcl_TransferResult(target, code, interp);
}
done:
@@ -506,8 +508,8 @@ Tcl_UnloadObjCmd(
int i, index, code, complain = 1, keepLibrary = 0;
int trustedRefCount = -1, safeRefCount = -1;
const char *fullFileName = "";
- char *packageName;
- static const char *options[] = {
+ const char *packageName;
+ static const char *const options[] = {
"-nocomplain", "-keeplibrary", "--", NULL
};
enum options {
@@ -550,7 +552,7 @@ Tcl_UnloadObjCmd(
endOfForLoop:
if ((objc-i < 1) || (objc-i > 3)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? fileName ?packageName? ?interp?");
+ "?-switch ...? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
@@ -572,6 +574,8 @@ Tcl_UnloadObjCmd(
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -582,8 +586,8 @@ Tcl_UnloadObjCmd(
target = interp;
if (objc - i == 3) {
- char *slaveIntName;
- slaveIntName = Tcl_GetString(objv[i+2]);
+ const char *slaveIntName = Tcl_GetString(objv[i + 2]);
+
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
return TCL_ERROR;
@@ -643,6 +647,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "package \"", packageName,
"\" is loaded statically and cannot be unloaded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -653,6 +659,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" has never been loaded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -665,8 +673,7 @@ Tcl_UnloadObjCmd(
code = TCL_ERROR;
if (pkgPtr != NULL) {
- ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
- "tclLoad", NULL);
+ ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
@@ -681,6 +688,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" has never been loaded in this interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -695,6 +704,8 @@ Tcl_UnloadObjCmd(
if (pkgPtr->safeUnloadProc == NULL) {
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded under a safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -703,6 +714,8 @@ Tcl_UnloadObjCmd(
if (pkgPtr->unloadProc == NULL) {
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded under a trusted interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -727,18 +740,18 @@ Tcl_UnloadObjCmd(
Tcl_MutexUnlock(&packageMutex);
if (Tcl_IsSafe(target)) {
- --safeRefCount;
+ safeRefCount--;
} else {
- --trustedRefCount;
+ trustedRefCount--;
}
if (safeRefCount <= 0 && trustedRefCount <= 0) {
code = TCL_UNLOAD_DETACH_FROM_PROCESS;
}
}
- code = (*unloadProc)(target, code);
+ code = unloadProc(target, code);
if (code != TCL_OK) {
- TclTransferResult(target, code, interp);
+ Tcl_TransferResult(target, code, interp);
goto done;
}
@@ -749,7 +762,7 @@ Tcl_UnloadObjCmd(
Tcl_MutexLock(&packageMutex);
if (Tcl_IsSafe(target)) {
- --pkgPtr->safeInterpRefCount;
+ pkgPtr->safeInterpRefCount--;
/*
* Do not let counter get negative.
@@ -759,7 +772,7 @@ Tcl_UnloadObjCmd(
pkgPtr->safeInterpRefCount = 0;
}
} else {
- --pkgPtr->interpRefCount;
+ pkgPtr->interpRefCount--;
/*
* Do not let counter get negative.
@@ -789,14 +802,8 @@ Tcl_UnloadObjCmd(
*/
if (pkgPtr->fileName[0] != '\0') {
- Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
-
- if (unLoadProcPtr != NULL) {
- Tcl_MutexLock(&packageMutex);
- if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) {
- (*unLoadProcPtr)(pkgPtr->loadHandle);
- }
-
+ Tcl_MutexLock(&packageMutex);
+ if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {
/*
* Remove this library from the loaded library cache.
*/
@@ -818,8 +825,7 @@ Tcl_UnloadObjCmd(
* Remove this library from the interpreter's library cache.
*/
- ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
- "tclLoad", NULL);
+ ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = ipFirstPtr;
if (ipPtr->pkgPtr == defaultPtr) {
ipFirstPtr = ipFirstPtr->nextPtr;
@@ -835,22 +841,21 @@ Tcl_UnloadObjCmd(
}
}
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
- (ClientData) ipFirstPtr);
+ ipFirstPtr);
ckfree(defaultPtr->fileName);
ckfree(defaultPtr->packageName);
- ckfree((char *) defaultPtr);
- ckfree((char *) ipPtr);
+ ckfree(defaultPtr);
+ ckfree(ipPtr);
Tcl_MutexUnlock(&packageMutex);
} else {
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded: filesystem does not support unloading",
- NULL);
code = TCL_ERROR;
}
}
#else
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded: unloading disabled", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
+ NULL);
code = TCL_ERROR;
#endif
}
@@ -875,8 +880,8 @@ Tcl_UnloadObjCmd(
* Our result is the two reference counts.
*/
- objPtr[0] = Tcl_NewIntObj(trustedRefCount);
- objPtr[1] = Tcl_NewIntObj(safeRefCount);
+ TclNewIntObj(objPtr[0], trustedRefCount);
+ TclNewIntObj(objPtr[1], safeRefCount);
if (objPtr[0] == NULL || objPtr[1] == NULL) {
if (objPtr[0]) {
Tcl_DecrRefCount(objPtr[0]);
@@ -885,7 +890,7 @@ Tcl_UnloadObjCmd(
Tcl_DecrRefCount(objPtr[1]);
}
} else {
- resultObjPtr = Tcl_NewListObj(2, objPtr);
+ TclNewListObj(resultObjPtr, 2, objPtr);
if (resultObjPtr != NULL) {
Tcl_SetObjResult(interp, resultObjPtr);
}
@@ -955,12 +960,11 @@ Tcl_StaticPackage(
* to the list now.
*/
- if ( pkgPtr == NULL ) {
- pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
+ if (pkgPtr == NULL) {
+ pkgPtr = ckalloc(sizeof(LoadedPackage));
+ pkgPtr->fileName = ckalloc(1);
pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = (char *)
- ckalloc((unsigned) (strlen(pkgName) + 1));
+ pkgPtr->packageName = ckalloc(strlen(pkgName) + 1);
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
@@ -978,10 +982,9 @@ Tcl_StaticPackage(
* it's already loaded.
*/
- ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp,
- "tclLoad", NULL);
- for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
- if ( ipPtr->pkgPtr == pkgPtr ) {
+ ipFirstPtr = Tcl_GetAssocData(interp, "tclLoad", NULL);
+ for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->pkgPtr == pkgPtr) {
return;
}
}
@@ -991,11 +994,10 @@ Tcl_StaticPackage(
* loaded.
*/
- ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+ ipPtr = ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
- Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
- (ClientData) ipPtr);
+ Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
}
@@ -1024,11 +1026,12 @@ int
TclGetLoadedPackages(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
- char *targetName) /* Name of target interpreter or NULL. If
+ const char *targetName) /* Name of target interpreter or NULL. If
* NULL, return info about all interps;
* otherwise, just return info about this
* interpreter. */
{
+ /* TODO: Use Tcl_Obj APIs to generate this info for cleanliness. */
Tcl_Interp *target;
LoadedPackage *pkgPtr;
InterpPackage *ipPtr;
@@ -1062,9 +1065,9 @@ TclGetLoadedPackages(
if (target == NULL) {
return TCL_ERROR;
}
- ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
prefix = "{";
- for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
pkgPtr = ipPtr->pkgPtr;
Tcl_AppendResult(interp, prefix, NULL);
Tcl_AppendElement(interp, pkgPtr->fileName);
@@ -1101,10 +1104,10 @@ LoadCleanupProc(
{
InterpPackage *ipPtr, *nextPtr;
- ipPtr = (InterpPackage *) clientData;
+ ipPtr = clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
- ckfree((char *) ipPtr);
+ ckfree(ipPtr);
ipPtr = nextPtr;
}
}
@@ -1134,8 +1137,8 @@ TclFinalizeLoad(void)
/*
* No synchronization here because there should just be one thread alive
* at this point. Logically, packageMutex should be grabbed at this point,
- * but the Mutexes get finalized before the call to this routine. The
- * only subsystem left alive at this point is the memory allocator.
+ * but the Mutexes get finalized before the call to this routine. The only
+ * subsystem left alive at this point is the memory allocator.
*/
while (firstPackagePtr != NULL) {
@@ -1151,18 +1154,13 @@ TclFinalizeLoad(void)
*/
if (pkgPtr->fileName[0] != '\0') {
- Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
- if ((unLoadProcPtr != NULL)
- && ((pkgPtr->unloadProc != NULL)
- || (unLoadProcPtr == TclFSUnloadTempFile))) {
- (*unLoadProcPtr)(pkgPtr->loadHandle);
- }
+ Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
}
#endif
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
- ckfree((char *) pkgPtr);
+ ckfree(pkgPtr);
}
}
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index d328a41..ac094e6 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -1,7 +1,7 @@
/*
* tclLoadNone.c --
*
- * This procedure provides a version of the TclLoadFile for use in
+ * This procedure provides a version of the TclpDlopen for use in
* systems that don't support dynamic loading; it just returns an error.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
@@ -53,33 +53,6 @@ TclpDlopen(
/*
*----------------------------------------------------------------------
*
- * TclpFindSymbol --
- *
- * Looks up a symbol, by name, through a handle associated with a
- * previously loaded piece of code (shared library). This version of this
- * routine should never be called because the associated TclpDlopen()
- * function always returns an error.
- *
- * Results:
- * Returns a pointer to the function associated with 'symbol' if it is
- * found. Otherwise returns NULL and may leave an error message in the
- * interp's result.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_PackageInitProc *
-TclpFindSymbol(
- Tcl_Interp *interp,
- Tcl_LoadHandle loadHandle,
- CONST char *symbol)
-{
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package name,
@@ -99,7 +72,7 @@ TclpFindSymbol(
int
TclGuessPackageName(
- CONST char *fileName, /* Name of file containing package (already
+ const char *fileName, /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
* name to this if possible. */
@@ -108,32 +81,6 @@ TclGuessPackageName(
}
/*
- *----------------------------------------------------------------------
- *
- * TclpUnloadFile --
- *
- * This procedure is called to carry out dynamic unloading of binary code;
- * it is intended for use only on systems that don't support dynamic
- * loading (it does nothing).
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpUnloadFile(
- Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
- * TclpDlopen(). The loadHandle is a token
- * that represents the loaded file. */
-{
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 7a19a38..26383b5 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -2,6 +2,11 @@
* tclMain.c --
*
* Main program for Tcl shells and other Tcl-based applications.
+ * This file contains a generic main program for Tcl shells and other
+ * Tcl-based applications. It can be used as-is for many applications,
+ * just by supplying a different appInitProc function for each specific
+ * application. Or, it can be used as a template for creating new main
+ * programs for Tcl applications.
*
* Copyright (c) 1988-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
@@ -11,10 +16,22 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include "tclInt.h"
+/**
+ * On Windows, this file needs to be compiled twice, once with
+ * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW
+ * can be implemented, sharing the same source code.
+ */
+#if defined(TCL_ASCII_MAIN)
+# ifdef UNICODE
+# undef UNICODE
+# undef _UNICODE
+# else
+# define UNICODE
+# define _UNICODE
+# endif
+#endif
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
+#include "tclInt.h"
/*
* The default prompt used when the user has not overridden it.
@@ -23,6 +40,37 @@
#define DEFAULT_PRIMARY_PROMPT "% "
/*
+ * This file can be compiled on Windows in UNICODE mode, as well as
+ * on all other platforms using the native encoding. This is done
+ * by using the normal Windows functions like _tcscmp, but on
+ * platforms which don't have <tchar.h> we have to translate that
+ * to strcmp here.
+ */
+#ifndef __WIN32__
+# define TCHAR char
+# define TEXT(arg) arg
+# define _tcscmp strcmp
+#endif
+
+/*
+ * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj,
+ * while otherwise NewNativeObj is needed (which provides proper
+ * conversion from native encoding to UTF-8).
+ */
+#ifdef UNICODE
+# define NewNativeObj Tcl_NewUnicodeObj
+#else /* !UNICODE */
+ static Tcl_Obj *NewNativeObj(char *string, int length) {
+ Tcl_Obj *obj;
+ Tcl_DString ds;
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ return obj;
+}
+#endif /* !UNICODE */
+
+/*
* Declarations for various library functions and variables (don't want to
* include tclPort.h here, because people might copy this file out of the Tcl
* source directory to make their own modified versions).
@@ -30,9 +78,20 @@
extern CRTIMPORT int isatty(int fd);
-static Tcl_Obj *tclStartupScriptPath = NULL;
-static Tcl_Obj *tclStartupScriptEncoding = NULL;
-static Tcl_MainLoopProc *mainLoopProc = NULL;
+/*
+ * The thread-local variables for this file's functions.
+ */
+
+typedef struct {
+ Tcl_Obj *path; /* The filename of the script for *_Main()
+ * routines to [source] as a startup script,
+ * or NULL for none set, meaning enter
+ * interactive mode. */
+ Tcl_Obj *encoding; /* The encoding of the startup script file. */
+ Tcl_MainLoopProc *mainLoopProc;
+ /* Any installed main loop handler. The main
+ * extension that installs these is Tk. */
+} ThreadSpecificData;
/*
* Structure definition for information used to keep the state of an
@@ -63,9 +122,12 @@ typedef struct InteractiveState {
* Forward declarations for functions defined later in this file.
*/
-static void Prompt(Tcl_Interp *interp, PromptType *promptPtr);
+MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
+static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
static void StdinProc(ClientData clientData, int mask);
+#ifndef TCL_ASCII_MAIN
+static Tcl_ThreadDataKey dataKey;
/*
*----------------------------------------------------------------------
*
@@ -85,27 +147,29 @@ static void StdinProc(ClientData clientData, int mask);
void
Tcl_SetStartupScript(
Tcl_Obj *path, /* Filesystem path of startup script file */
- CONST char *encoding) /* Encoding of the data in that file */
+ const char *encoding) /* Encoding of the data in that file */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Obj *newEncoding = NULL;
+
if (encoding != NULL) {
newEncoding = Tcl_NewStringObj(encoding, -1);
}
- if (tclStartupScriptPath != NULL) {
- Tcl_DecrRefCount(tclStartupScriptPath);
+ if (tsdPtr->path != NULL) {
+ Tcl_DecrRefCount(tsdPtr->path);
}
- tclStartupScriptPath = path;
- if (tclStartupScriptPath != NULL) {
- Tcl_IncrRefCount(tclStartupScriptPath);
+ tsdPtr->path = path;
+ if (tsdPtr->path != NULL) {
+ Tcl_IncrRefCount(tsdPtr->path);
}
- if (tclStartupScriptEncoding != NULL) {
- Tcl_DecrRefCount(tclStartupScriptEncoding);
+ if (tsdPtr->encoding != NULL) {
+ Tcl_DecrRefCount(tsdPtr->encoding);
}
- tclStartupScriptEncoding = newEncoding;
- if (tclStartupScriptEncoding != NULL) {
- Tcl_IncrRefCount(tclStartupScriptEncoding);
+ tsdPtr->encoding = newEncoding;
+ if (tsdPtr->encoding != NULL) {
+ Tcl_IncrRefCount(tsdPtr->encoding);
}
}
@@ -121,131 +185,31 @@ Tcl_SetStartupScript(
* The path of the startup script; NULL if none has been set.
*
* Side effects:
- * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to
- * the encoding name registered for the startup script. Tcl retains
- * ownership of the string, and may free it. Caller should make a copy
- * for long-term use.
+ * If encodingPtr is not NULL, stores a (const char *) in it pointing to
+ * the encoding name registered for the startup script. Tcl retains
+ * ownership of the string, and may free it. Caller should make a copy
+ * for long-term use.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetStartupScript(
- CONST char **encodingPtr) /* When not NULL, points to storage for the
- * (CONST char *) that points to the
+ const char **encodingPtr) /* When not NULL, points to storage for the
+ * (const char *) that points to the
* registered encoding name for the startup
- * script */
+ * script. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
if (encodingPtr != NULL) {
- if (tclStartupScriptEncoding == NULL) {
+ if (tsdPtr->encoding == NULL) {
*encodingPtr = NULL;
} else {
- *encodingPtr = Tcl_GetString(tclStartupScriptEncoding);
+ *encodingPtr = Tcl_GetString(tsdPtr->encoding);
}
}
- return tclStartupScriptPath;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetStartupScriptPath --
- *
- * Primes the startup script VFS path, used to override the command line
- * processing.
- *
- * Results:
- * None.
- *
- * Side effects:
- * This function initializes the VFS path of the Tcl script to run at
- * startup.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclSetStartupScriptPath(
- Tcl_Obj *path)
-{
- Tcl_SetStartupScript(path, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetStartupScriptPath --
- *
- * Gets the startup script VFS path, used to override the command line
- * processing.
- *
- * Results:
- * The startup script VFS path, NULL if none has been set.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclGetStartupScriptPath(void)
-{
- return Tcl_GetStartupScript(NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetStartupScriptFileName --
- *
- * Primes the startup script file name, used to override the command line
- * processing.
- *
- * Results:
- * None.
- *
- * Side effects:
- * This function initializes the file name of the Tcl script to run at
- * startup.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclSetStartupScriptFileName(
- CONST char *fileName)
-{
- Tcl_Obj *path = Tcl_NewStringObj(fileName,-1);
- Tcl_SetStartupScript(path, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetStartupScriptFileName --
- *
- * Gets the startup script file name, used to override the command line
- * processing.
- *
- * Results:
- * The startup script file name, NULL if none has been set.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-CONST char *
-TclGetStartupScriptFileName(void)
-{
- Tcl_Obj *path = Tcl_GetStartupScript(NULL);
-
- if (path == NULL) {
- return NULL;
- }
- return Tcl_GetString(path);
+ return tsdPtr->path;
}
/*----------------------------------------------------------------------
@@ -270,13 +234,13 @@ Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
- CONST char *fileName;
- Tcl_Channel errChannel;
+ const char *fileName;
+ Tcl_Channel chan;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
- CONST char *fullName;
+ const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
@@ -292,24 +256,25 @@ Tcl_SourceRCFile(
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
- if (c != (Tcl_Channel) NULL) {
+ if (c != NULL) {
Tcl_Close(NULL, c);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
- }
- }
- }
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
+ }
+ }
+ }
}
Tcl_DStringFree(&temp);
}
}
+#endif /* !TCL_ASCII_MAIN */
/*----------------------------------------------------------------------
*
- * Tcl_Main --
+ * Tcl_Main, Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -326,27 +291,28 @@ Tcl_SourceRCFile(
*/
void
-Tcl_Main(
+Tcl_MainEx(
int argc, /* Number of arguments. */
- char **argv, /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc)
+ TCHAR **argv, /* Array of argument strings. */
+ Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
+ Tcl_Interp *interp)
{
- Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;
- CONST char *encodingName = NULL;
- PromptType prompt = PROMPT_START;
- int code, length, tty, exitCode = 0;
- Tcl_Channel inChannel, outChannel, errChannel;
- Tcl_Interp *interp;
- Tcl_DString appName;
-
- Tcl_FindExecutable(argv[0]);
+ Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
+ const char *encodingName = NULL;
+ int code, exitCode = 0;
+ Tcl_MainLoopProc *mainLoopProc;
+ Tcl_Channel chan;
+ InteractiveState is;
- interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
+ is.interp = interp;
+ is.prompt = PROMPT_START;
+ is.commandPtr = Tcl_NewObj();
+
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
@@ -354,21 +320,22 @@ Tcl_Main(
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
-
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
- * -encoding ENCODING FILENAME
+ * -encoding ENCODING FILENAME
* or like
- * FILENAME
+ * FILENAME
*/
- if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
- && ('-' != argv[3][0])) {
- Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
+ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
+ && (TEXT('-') != argv[3][0])) {
+ Tcl_Obj *value = NewNativeObj(argv[2], -1);
+ Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value));
+ Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
- } else if ((argc > 1) && ('-' != argv[1][0])) {
- Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
+ } else if ((argc > 1) && (TEXT('-') != argv[1][0])) {
+ Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
@@ -376,15 +343,11 @@ Tcl_Main(
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
- Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
+ appName = NewNativeObj(argv[0], -1);
} else {
- CONST char *pathName = Tcl_GetStringFromObj(path, &length);
- Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
- path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
- Tcl_SetStartupScript(path, encodingName);
+ appName = path;
}
- Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
- Tcl_DStringFree(&appName);
+ Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
@@ -392,11 +355,7 @@ Tcl_Main(
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
- Tcl_DString ds;
- Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
- Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
- Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
+ Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
@@ -404,22 +363,22 @@ Tcl_Main(
* Set the "tcl_interactive" variable.
*/
- tty = isatty(0);
- Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
- TCL_GLOBAL_ONLY);
+ is.tty = isatty(0);
+ Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
+ Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
- Tcl_Preserve((ClientData) interp);
- if ((*appInitProc)(interp) != TCL_OK) {
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel) {
- Tcl_WriteChars(errChannel,
+ Tcl_Preserve(interp);
+ if (appInitProc(interp) != TCL_OK) {
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
+ Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
@@ -430,16 +389,17 @@ Tcl_Main(
}
/*
- * If a script file was specified then just source that file and quit.
- * Must fetch it again, as the appInitProc might have reset it.
+ * Invoke the script specified on the command line, if any. Must fetch it
+ * again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
+ Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel) {
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
@@ -449,9 +409,9 @@ Tcl_Main(
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
- Tcl_WriteObj(errChannel, valuePtr);
+ Tcl_WriteObj(chan, valuePtr);
}
- Tcl_WriteChars(errChannel, "\n", 1);
+ Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
@@ -475,45 +435,45 @@ Tcl_Main(
* may have been changed.
*/
- commandPtr = Tcl_NewObj();
- Tcl_IncrRefCount(commandPtr);
+ Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
- Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
+ is.input = Tcl_GetStdChannel(TCL_STDIN);
+ while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
+ mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
- if (tty) {
- Prompt(interp, &prompt);
+ int length;
+ if (is.tty) {
+ Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- if (inChannel == (Tcl_Channel) NULL) {
+ is.input = Tcl_GetStdChannel(TCL_STDIN);
+ if (is.input == NULL) {
break;
}
}
- if (Tcl_IsShared(commandPtr)) {
- Tcl_DecrRefCount(commandPtr);
- commandPtr = Tcl_DuplicateObj(commandPtr);
- Tcl_IncrRefCount(commandPtr);
+ if (Tcl_IsShared(is.commandPtr)) {
+ Tcl_DecrRefCount(is.commandPtr);
+ is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
+ Tcl_IncrRefCount(is.commandPtr);
}
- length = Tcl_GetsObj(inChannel, commandPtr);
+ length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
- if (Tcl_InputBlocked(inChannel)) {
+ if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
- * non-blocking. In that case cycle back and try again.
+ * non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
- * event loop running). If this causes bad CPU hogging,
- * we might try toggling the blocking on stdin instead.
+ * event loop running). If this causes bad CPU hogging, we
+ * might try toggling the blocking on stdin instead.
*/
continue;
@@ -527,48 +487,50 @@ Tcl_Main(
}
/*
- * Add the newline removed by Tcl_GetsObj back to the string.
- * Have to add it back before testing completeness, because
- * it can make a difference. [Bug 1775878].
+ * Add the newline removed by Tcl_GetsObj back to the string. Have
+ * to add it back before testing completeness, because it can make
+ * a difference. [Bug 1775878]
*/
- if (Tcl_IsShared(commandPtr)) {
- Tcl_DecrRefCount(commandPtr);
- commandPtr = Tcl_DuplicateObj(commandPtr);
- Tcl_IncrRefCount(commandPtr);
+ if (Tcl_IsShared(is.commandPtr)) {
+ Tcl_DecrRefCount(is.commandPtr);
+ is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
+ Tcl_IncrRefCount(is.commandPtr);
}
- Tcl_AppendToObj(commandPtr, "\n", 1);
- if (!TclObjCommandComplete(commandPtr)) {
- prompt = PROMPT_CONTINUE;
+ Tcl_AppendToObj(is.commandPtr, "\n", 1);
+ if (!TclObjCommandComplete(is.commandPtr)) {
+ is.prompt = PROMPT_CONTINUE;
continue;
}
- prompt = PROMPT_START;
+ is.prompt = PROMPT_START;
+
/*
- * The final newline is syntactically redundant, and causes
- * some error messages troubles deeper in, so lop it back off.
+ * The final newline is syntactically redundant, and causes some
+ * error messages troubles deeper in, so lop it back off.
*/
- Tcl_GetStringFromObj(commandPtr, &length);
- Tcl_SetObjLength(commandPtr, --length);
- code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- Tcl_DecrRefCount(commandPtr);
- commandPtr = Tcl_NewObj();
- Tcl_IncrRefCount(commandPtr);
+
+ Tcl_GetStringFromObj(is.commandPtr, &length);
+ Tcl_SetObjLength(is.commandPtr, --length);
+ code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL);
+ is.input = Tcl_GetStdChannel(TCL_STDIN);
+ Tcl_DecrRefCount(is.commandPtr);
+ is.commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
- if (errChannel) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
}
- } else if (tty) {
+ } else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
- if ((length > 0) && outChannel) {
- Tcl_WriteObj(outChannel, resultPtr);
- Tcl_WriteChars(outChannel, "\n", 1);
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if ((length > 0) && chan) {
+ Tcl_WriteObj(chan, resultPtr);
+ Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
@@ -579,47 +541,21 @@ Tcl_Main(
* channel handler for stdin.
*/
- InteractiveState *isPtr = NULL;
-
- if (inChannel) {
- if (tty) {
- Prompt(interp, &prompt);
+ if (is.input) {
+ if (is.tty) {
+ Prompt(interp, &is);
}
- isPtr = (InteractiveState *)
- ckalloc((int) sizeof(InteractiveState));
- isPtr->input = inChannel;
- isPtr->tty = tty;
- isPtr->commandPtr = commandPtr;
- isPtr->prompt = prompt;
- isPtr->interp = interp;
-
- Tcl_UnlinkVar(interp, "tcl_interactive");
- Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
- TCL_LINK_BOOLEAN);
-
- Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
- (ClientData) isPtr);
+
+ Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is);
}
- (*mainLoopProc)();
- mainLoopProc = NULL;
-
- if (inChannel) {
- tty = isPtr->tty;
- Tcl_UnlinkVar(interp, "tcl_interactive");
- Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
- TCL_LINK_BOOLEAN);
- prompt = isPtr->prompt;
- commandPtr = isPtr->commandPtr;
- if (isPtr->input != (Tcl_Channel) NULL) {
- Tcl_DeleteChannelHandler(isPtr->input, StdinProc,
- (ClientData) isPtr);
- }
- ckfree((char *)isPtr);
+ mainLoopProc();
+ Tcl_SetMainLoop(NULL);
+
+ if (is.input) {
+ Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ is.input = Tcl_GetStdChannel(TCL_STDIN);
}
#ifdef TCL_MEM_DEBUG
@@ -629,13 +565,14 @@ Tcl_Main(
*/
if (tclMemDumpFileName != NULL) {
- mainLoopProc = NULL;
+ Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif
}
done:
+ mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && (mainLoopProc != NULL)
&& !Tcl_LimitExceeded(interp)) {
/*
@@ -644,11 +581,11 @@ Tcl_Main(
* this point.
*/
- (*mainLoopProc)();
- mainLoopProc = NULL;
+ mainLoopProc();
+ Tcl_SetMainLoop(NULL);
}
- if (commandPtr != NULL) {
- Tcl_DecrRefCount(commandPtr);
+ if (is.commandPtr != NULL) {
+ Tcl_DecrRefCount(is.commandPtr);
}
/*
@@ -660,6 +597,7 @@ Tcl_Main(
if (!Tcl_InterpDeleted(interp)) {
if (!Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
+
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
@@ -683,10 +621,27 @@ Tcl_Main(
* destruction with the last matching Tcl_Release.
*/
- Tcl_Release((ClientData) interp);
+ Tcl_Release(interp);
Tcl_Exit(exitCode);
}
+
+#ifndef UNICODE
+void
+Tcl_Main(
+ int argc, /* Number of arguments. */
+ TCHAR **argv, /* Array of argument strings. */
+ Tcl_AppInitProc *appInitProc)
+ /* Application-specific initialization
+ * function to call after most initialization
+ * but before starting to execute commands. */
+{
+ Tcl_FindExecutable(argv[0]);
+ Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
+}
+#endif
+#ifndef TCL_ASCII_MAIN
+
/*
*---------------------------------------------------------------
*
@@ -695,7 +650,7 @@ Tcl_Main(
* Sets an alternative main loop function.
*
* Results:
- * Returns the previously defined main loop function.
+ * None.
*
* Side effects:
* This function will be called before Tcl exits, allowing for the
@@ -708,8 +663,38 @@ void
Tcl_SetMainLoop(
Tcl_MainLoopProc *proc)
{
- mainLoopProc = proc;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ tsdPtr->mainLoopProc = proc;
+}
+
+/*
+ *---------------------------------------------------------------
+ *
+ * TclGetMainLoop --
+ *
+ * Returns the current alternative main loop function.
+ *
+ * Results:
+ * Returns the previously defined main loop function, or NULL to indicate
+ * that no such function has been installed and standard tclsh behaviour
+ * (i.e., exit once the script is evaluated if not interactive) is
+ * requested..
+ *
+ * Side effects:
+ * None (other than possible creation of this file's TSD block).
+ *
+ *---------------------------------------------------------------
+ */
+
+Tcl_MainLoopProc *
+TclGetMainLoop(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ return tsdPtr->mainLoopProc;
}
+#endif /* !TCL_ASCII_MAIN */
/*
*----------------------------------------------------------------------
@@ -736,11 +721,11 @@ StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
- InteractiveState *isPtr = (InteractiveState *) clientData;
+ int code, length;
+ InteractiveState *isPtr = clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
- int code, length;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
@@ -761,7 +746,7 @@ StdinProc(
Tcl_Exit(0);
}
- Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
+ Tcl_DeleteChannelHandler(chan, StdinProc, isPtr);
return;
}
@@ -786,30 +771,31 @@ StdinProc(
* things, this will trash the text of the command being evaluated.
*/
- Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
+ Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
isPtr->commandPtr = commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
- (ClientData) isPtr);
+ if (chan != NULL) {
+ Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr);
}
if (code != TCL_OK) {
- Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+
+ if (chan != NULL) {
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
- if ((length >0) && (outChannel != (Tcl_Channel) NULL)) {
- Tcl_WriteObj(outChannel, resultPtr);
- Tcl_WriteChars(outChannel, "\n", 1);
+ if ((length > 0) && (chan != NULL)) {
+ Tcl_WriteObj(chan, resultPtr);
+ Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
@@ -819,8 +805,8 @@ StdinProc(
*/
prompt:
- if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
- Prompt(interp, &(isPtr->prompt));
+ if (isPtr->tty && (isPtr->input != NULL)) {
+ Prompt(interp, isPtr);
isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
}
@@ -845,20 +831,20 @@ StdinProc(
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
- PromptType *promptPtr) /* Points to type of prompt to print. Filled
+ InteractiveState *isPtr) /* InteractiveState. Filled
* with PROMPT_NONE after a prompt is
* printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
- Tcl_Channel outChannel, errChannel;
+ Tcl_Channel chan;
- if (*promptPtr == PROMPT_NONE) {
+ if (isPtr->prompt == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
- ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
+ ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
@@ -866,31 +852,32 @@ Prompt(
}
if (promptCmdPtr == NULL) {
defaultPrompt:
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- if ((*promptPtr == PROMPT_START)
- && (outChannel != (Tcl_Channel) NULL)) {
- Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
- strlen(DEFAULT_PRIMARY_PROMPT));
+ if (isPtr->prompt == PROMPT_START) {
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (chan != NULL) {
+ Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
+ strlen(DEFAULT_PRIMARY_PROMPT));
+ }
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan != NULL) {
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
}
goto defaultPrompt;
}
}
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- if (outChannel != (Tcl_Channel) NULL) {
- Tcl_Flush(outChannel);
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (chan != NULL) {
+ Tcl_Flush(chan);
}
- *promptPtr = PROMPT_NONE;
+ isPtr->prompt = PROMPT_NONE;
}
/*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5dbffc6..f3c93e7 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -5,8 +5,7 @@
* commands and global variables. The global :: namespace is the
* traditional Tcl "global" scope. Other namespaces are created as
* children of the global namespace. These other namespaces contain
- * special-purpose commands and variables for packages. Also includes the
- * TIP#112 ensemble machinery.
+ * special-purpose commands and variables for packages.
*
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1997 Sun Microsystems, Inc.
@@ -25,6 +24,7 @@
*/
#include "tclInt.h"
+#include "tclCompile.h" /* for NRCommand; and TclLogCommandInfo visibility */
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -53,12 +53,12 @@ static Tcl_ThreadDataKey dataKey;
*/
typedef struct ResolvedNsName {
- Namespace *nsPtr; /* A cached pointer to the Namespace that the
- * name resolved to. */
- Namespace *refNsPtr; /* Points to the namespace context in which the
- * name was resolved. NULL if the name is fully
- * qualified and thus the resolution does not
- * depend on the context. */
+ Namespace *nsPtr; /* A cached pointer to the Namespace that the
+ * name resolved to. */
+ Namespace *refNsPtr; /* Points to the namespace context in which
+ * the name was resolved. NULL if the name is
+ * fully qualified and thus the resolution
+ * does not depend on the context. */
int refCount; /* Reference count: 1 for each nsName object
* that has a pointer to this ResolvedNsName
* structure as its internal rep. This
@@ -67,82 +67,6 @@ typedef struct ResolvedNsName {
} ResolvedNsName;
/*
- * The client data for an ensemble command. This consists of the table of
- * commands that are actually exported by the namespace, and an epoch counter
- * that, combined with the exportLookupEpoch field of the namespace structure,
- * defines whether the table contains valid data or will need to be recomputed
- * next time the ensemble command is called.
- */
-
-typedef struct EnsembleConfig {
- Namespace *nsPtr; /* The namspace backing this ensemble up. */
- Tcl_Command token; /* The token for the command that provides
- * ensemble support for the namespace, or NULL
- * if the command has been deleted (or never
- * existed; the global namespace never has an
- * ensemble command.) */
- int epoch; /* The epoch at which this ensemble's table of
- * exported commands is valid. */
- char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
- * consistent points, this will have the same
- * number of entries as there are entries in
- * the subcommandTable hash. */
- Tcl_HashTable subcommandTable;
- /* Hash table of ensemble subcommand names,
- * which are its keys so this also provides
- * the storage management for those subcommand
- * names. The contents of the entry values are
- * object version the prefix lists to use when
- * substituting for the command/subcommand to
- * build the ensemble implementation command.
- * Has to be stored here as well as in
- * subcommandDict because that field is NULL
- * when we are deriving the ensemble from the
- * namespace exports list. FUTURE WORK: use
- * object hash table here. */
- struct EnsembleConfig *next;/* The next ensemble in the linked list of
- * ensembles associated with a namespace. If
- * this field points to this ensemble, the
- * structure has already been unlinked from
- * all lists, and cannot be found by scanning
- * the list from the namespace's ensemble
- * field. */
- int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD
- * and ENSEMBLE_COMPILE. */
-
- /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
-
- Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
- * subcommands to their implementing command
- * prefixes, or NULL if we are to build the
- * map automatically from the namespace
- * exports. */
- Tcl_Obj *subcmdList; /* List of commands that this ensemble
- * actually provides, and whose implementation
- * will be built using the subcommandDict (if
- * present and defined) and by simple mapping
- * to the namespace otherwise. If NULL,
- * indicates that we are using the (dynamic)
- * list of currently exported commands. */
- Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
- * no match is found (according to the rule
- * defined by flag bit TCL_ENSEMBLE_PREFIX) or
- * NULL to use the default error-generating
- * behaviour. The script execution gets all
- * the arguments to the ensemble command
- * (including objv[0]) and will have the
- * results passed directly back to the caller
- * (including the error code) unless the code
- * is TCL_CONTINUE in which case the
- * subcommand will be reparsed by the ensemble
- * core, presumably because the ensemble
- * itself has been updated. */
-} EnsembleConfig;
-
-#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead
- * and on its way out. */
-
-/*
* Declarations for functions local to this file:
*/
@@ -167,6 +91,8 @@ static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
static int InvokeImportedCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int InvokeImportedNRCmd(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceChildrenCmd(ClientData dummy,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
@@ -175,10 +101,10 @@ static int NamespaceCurrentCmd(ClientData dummy,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int NamespaceEnsembleCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int NRNamespaceEvalCmd(ClientData dummy,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
@@ -190,6 +116,8 @@ static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceInscopeCmd(ClientData dummy,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int NRNamespaceInscopeCmd(ClientData dummy,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
@@ -203,25 +131,14 @@ static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceUnknownCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static int NsEnsembleImplementationCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
-static int NsEnsembleStringOrder(const void *strPtr1,
- const void *strPtr2);
-static void DeleteEnsembleConfig(ClientData clientData);
-static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
- EnsembleConfig *ensemblePtr,
- const char *subcmdName, Tcl_Obj *prefixObjPtr);
-static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
-static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
-static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
+static Tcl_NRPostProc NsEval_Callback;
+
/*
* This structure defines a Tcl object type that contains a namespace
* reference. It is used in commands that take the name of a namespace as an
@@ -229,7 +146,7 @@ static void UnlinkNsPath(Namespace *nsPtr);
* the object.
*/
-static Tcl_ObjType nsNameType = {
+static const Tcl_ObjType nsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
@@ -238,18 +155,31 @@ static Tcl_ObjType nsNameType = {
};
/*
- * This structure defines a Tcl object type that contains a reference to an
- * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
- * to cache the mapping between the subcommand itself and the real command
- * that implements it.
+ * Array of values describing how to implement each standard subcommand of the
+ * "namespace" command.
*/
-Tcl_ObjType tclEnsembleCmdType = {
- "ensembleCommand", /* the type's name */
- FreeEnsembleCmdRep, /* freeIntRepProc */
- DupEnsembleCmdRep, /* dupIntRepProc */
- StringOfEnsembleCmdRep, /* updateStringProc */
- NULL /* setFromAnyProc */
+static const EnsembleImplMap defaultNamespaceMap[] = {
+ {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+ {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0},
+ {"current", NamespaceCurrentCmd, NULL, NULL, NULL, 0},
+ {"delete", NamespaceDeleteCmd, NULL, 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},
+ {"inscope", NamespaceInscopeCmd, NULL, NULL, NRNamespaceInscopeCmd, 0},
+ {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
+ {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
+ {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
+ {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
+ {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
+ {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+ {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
+ {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -412,7 +342,8 @@ Tcl_PushCallFrame(
framePtr->compiledLocals = NULL;
framePtr->clientData = NULL;
framePtr->localCachePtr = NULL;
-
+ framePtr->tailcallPtr = NULL;
+
/*
* Push the new call frame onto the interpreter's stack of procedure call
* frames making it the current frame.
@@ -420,6 +351,7 @@ Tcl_PushCallFrame(
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
+
return TCL_OK;
}
@@ -465,7 +397,7 @@ Tcl_PopCallFrame(
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
- ckfree((char *) framePtr->varTablePtr);
+ ckfree(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
@@ -489,6 +421,10 @@ Tcl_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ }
}
/*
@@ -529,7 +465,7 @@ TclPushStackFrame(
* treated as references to namespace
* variables. */
{
- *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
+ *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame));
return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
isProcCallFrame);
}
@@ -538,7 +474,7 @@ void
TclPopStackFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
- CallFrame *freePtr = ((Interp *)interp)->framePtr;
+ CallFrame *freePtr = ((Interp *) interp)->framePtr;
Tcl_PopCallFrame(interp);
TclStackFree(interp, freePtr);
@@ -601,7 +537,7 @@ ErrorCodeRead(
const char *name2,
int flags)
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
@@ -754,6 +690,8 @@ Tcl_CreateNamespace(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't create namespace \"\": "
"only global namespace can have empty name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEGLOBAL", NULL);
return NULL;
} else {
/*
@@ -779,9 +717,18 @@ Tcl_CreateNamespace(
* already exist in the parent namespace.
*/
- if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
+ if (
+#ifndef BREAK_NAMESPACE_COMPAT
+ Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
+#else
+ parentPtr->childTablePtr != NULL &&
+ Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
+#endif
+ ) {
Tcl_AppendResult(interp, "can't create namespace \"", name,
"\": already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEEXISTING", NULL);
return NULL;
}
}
@@ -791,14 +738,19 @@ Tcl_CreateNamespace(
* of namespaces created.
*/
- nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
- nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1));
- strcpy(nsPtr->name, simpleName);
+ nsPtr = ckalloc(sizeof(Namespace));
+ nameLen = strlen(simpleName) + 1;
+ nsPtr->name = ckalloc(nameLen);
+ memcpy(nsPtr->name, simpleName, nameLen);
nsPtr->fullName = NULL; /* Set below. */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
+#ifndef BREAK_NAMESPACE_COMPAT
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
+#else
+ nsPtr->childTablePtr = NULL;
+#endif
nsPtr->nsId = ++(tsdPtr->numNsCreated);
nsPtr->interp = interp;
nsPtr->flags = 0;
@@ -820,10 +772,12 @@ Tcl_CreateNamespace(
nsPtr->commandPathLength = 0;
nsPtr->commandPathArray = NULL;
nsPtr->commandPathSourceList = NULL;
+ nsPtr->earlyDeleteProc = NULL;
if (parentPtr != NULL) {
- entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
- &newEntry);
+ entryPtr = Tcl_CreateHashEntry(
+ TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr),
+ simpleName, &newEntry);
Tcl_SetHashValue(entryPtr, nsPtr);
} else {
/*
@@ -875,13 +829,23 @@ Tcl_CreateNamespace(
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
- nsPtr->fullName = ckalloc((unsigned) (nameLen+1));
+ nsPtr->fullName = ckalloc(nameLen + 1);
memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
/*
+ * If compilation of commands originating from the parent NS is
+ * suppressed, suppress it for commands originating in this one too.
+ */
+
+ if (nsPtr->parentPtr != NULL &&
+ nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) {
+ nsPtr->flags |= NS_SUPPRESS_COMPILATION;
+ }
+
+ /*
* Return a pointer to the new namespace.
*/
@@ -916,6 +880,50 @@ Tcl_DeleteNamespace(
Namespace *globalNsPtr = (Namespace *)
TclGetGlobalNamespace((Tcl_Interp *) iPtr);
Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Command *cmdPtr;
+
+ /*
+ * Give anyone interested - notably TclOO - a chance to use this namespace
+ * normally despite the fact that the namespace is going to go. Allows the
+ * calling of destructors. Will only be called once (unless re-established
+ * by the called function). [Bug 2950259]
+ *
+ * Note that setting this field requires access to the internal definition
+ * of namespaces, so it should only be accessed by code that knows about
+ * being careful with reentrancy.
+ */
+
+ if (nsPtr->earlyDeleteProc != NULL) {
+ Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc;
+
+ nsPtr->earlyDeleteProc = NULL;
+ nsPtr->activationCount++;
+ earlyDeleteProc(nsPtr->clientData);
+ nsPtr->activationCount--;
+ }
+
+ /*
+ * Delete all coroutine commands now: break the circular ref cycle between
+ * the namespace and the coroutine command [Bug 2724403]. This code is
+ * essentially duplicated in TclTeardownNamespace() for all other
+ * commands. Don't optimize to Tcl_NextHashEntry() because of traces.
+ *
+ * NOTE: we could avoid traversing the ns's command list by keeping a
+ * separate list of coros.
+ */
+
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ entryPtr != NULL;) {
+ cmdPtr = Tcl_GetHashValue(entryPtr);
+ if (cmdPtr->nreProc == NRInterpCoroutine) {
+ Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
+ (Tcl_Command) cmdPtr);
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ } else {
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
/*
* If the namespace has associated ensemble commands, delete them first.
@@ -966,8 +974,9 @@ Tcl_DeleteNamespace(
if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
- entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
- nsPtr->name);
+ entryPtr = Tcl_FindHashEntry(
+ TclGetNamespaceChildTable((Tcl_Namespace *)
+ nsPtr->parentPtr), nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
@@ -996,7 +1005,14 @@ Tcl_DeleteNamespace(
TclDeleteNamespaceVars(nsPtr);
+#ifndef BREAK_NAMESPACE_COMPAT
Tcl_DeleteHashTable(&nsPtr->childTable);
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ Tcl_DeleteHashTable(nsPtr->childTablePtr);
+ ckfree(nsPtr->childTablePtr);
+ }
+#endif
Tcl_DeleteHashTable(&nsPtr->cmdTable);
/*
@@ -1092,8 +1108,9 @@ TclTeardownNamespace(
*/
if (nsPtr->parentPtr != NULL) {
- entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
- nsPtr->name);
+ entryPtr = Tcl_FindHashEntry(
+ TclGetNamespaceChildTable((Tcl_Namespace *)
+ nsPtr->parentPtr), nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
@@ -1110,6 +1127,7 @@ TclTeardownNamespace(
}
if (nsPtr->commandPathSourceList != NULL) {
NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+
do {
if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) {
nsPathPtr->creatorNsPtr->cmdRefEpoch++;
@@ -1130,12 +1148,23 @@ TclTeardownNamespace(
* Don't optimize to Tcl_NextHashEntry() because of traces.
*/
+#ifndef BREAK_NAMESPACE_COMPAT
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
childNsPtr = Tcl_GetHashValue(entryPtr);
Tcl_DeleteNamespace(childNsPtr);
}
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) {
+ childNsPtr = Tcl_GetHashValue(entryPtr);
+ Tcl_DeleteNamespace(childNsPtr);
+ }
+ }
+#endif
/*
* Free the namespace's export pattern array.
@@ -1145,7 +1174,7 @@ TclTeardownNamespace(
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
- ckfree((char *) nsPtr->exportArrayPtr);
+ ckfree(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
@@ -1156,7 +1185,7 @@ TclTeardownNamespace(
*/
if (nsPtr->deleteProc != NULL) {
- (*nsPtr->deleteProc)(nsPtr->clientData);
+ nsPtr->deleteProc(nsPtr->clientData);
}
nsPtr->deleteProc = NULL;
nsPtr->clientData = NULL;
@@ -1199,8 +1228,34 @@ NamespaceFree(
ckfree(nsPtr->name);
ckfree(nsPtr->fullName);
+ ckfree(nsPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNsDecrRefCount --
+ *
+ * Drops a reference to a namespace and frees it if the namespace has
+ * been deleted and the last reference has just been dropped.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- ckfree((char *) nsPtr);
+void
+TclNsDecrRefCount(
+ Namespace *nsPtr)
+{
+ nsPtr->refCount--;
+ if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
+ NamespaceFree(nsPtr);
+ }
}
/*
@@ -1265,7 +1320,7 @@ Tcl_Export(
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
- ckfree((char *) nsPtr->exportArrayPtr);
+ ckfree(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
TclInvalidateNsCmdLookup(nsPtr);
nsPtr->numExportPatterns = 0;
@@ -1284,6 +1339,7 @@ Tcl_Export(
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
"\": pattern can't specify a namespace", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
@@ -1312,8 +1368,7 @@ Tcl_Export(
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
- nsPtr->exportArrayPtr = (char **)
- ckrealloc((char *) nsPtr->exportArrayPtr,
+ nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
@@ -1322,7 +1377,7 @@ Tcl_Export(
*/
len = strlen(pattern);
- patternCpy = ckalloc((unsigned) (len + 1));
+ patternCpy = ckalloc(len + 1);
memcpy(patternCpy, pattern, (unsigned) len + 1);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
@@ -1488,7 +1543,8 @@ Tcl_Import(
*/
if (strlen(pattern) == 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1506,10 +1562,12 @@ Tcl_Import(
Tcl_AppendResult(interp,
"no namespace specified in import pattern \"", pattern,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
Tcl_AppendResult(interp, "import pattern \"", pattern,
"\" tries to import from namespace \"",
importNsPtr->name, "\" into itself", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
}
@@ -1532,6 +1590,7 @@ Tcl_Import(
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
+
if (Tcl_StringMatch(cmdName, simplePattern) &&
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
allowOverwrite) == TCL_ERROR) {
@@ -1579,7 +1638,8 @@ DoImport(
*/
while (!exported && (i < importNsPtr->numExportPatterns)) {
- exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
+ exported |= Tcl_StringMatch(cmdName,
+ importNsPtr->exportArrayPtr[i++]);
}
if (!exported) {
return TCL_OK;
@@ -1619,25 +1679,26 @@ DoImport(
cmdPtr = Tcl_GetHashValue(hPtr);
if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = Tcl_GetHashValue(found);
- Command *link = cmdPtr;
-
- while (link->deleteProc == DeleteImportedCmd) {
- ImportedCmdData *dataPtr = link->objClientData;
+ Command *linkCmd = cmdPtr;
- link = dataPtr->realCmdPtr;
- if (overwrite == link) {
+ while (linkCmd->deleteProc == DeleteImportedCmd) {
+ dataPtr = linkCmd->objClientData;
+ linkCmd = dataPtr->realCmdPtr;
+ if (overwrite == linkCmd) {
Tcl_AppendResult(interp, "import pattern \"", pattern,
"\" would create a loop containing command \"",
Tcl_DStringValue(&ds), "\"", NULL);
Tcl_DStringFree(&ds);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
}
- dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
- importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, dataPtr, DeleteImportedCmd);
+ dataPtr = ckalloc(sizeof(ImportedCmdData));
+ importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
+ InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
@@ -1648,7 +1709,7 @@ DoImport(
* and add it to the import ref list in the "real" command.
*/
- refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
+ refPtr = ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
@@ -1668,6 +1729,7 @@ DoImport(
}
Tcl_AppendResult(interp, "can't import command \"", cmdName,
"\": already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1748,13 +1810,13 @@ Tcl_ForgetImport(
*/
if (TclMatchIsTrivial(simplePattern)) {
- Command *cmdPtr;
-
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
- if ((hPtr != NULL)
- && (cmdPtr = Tcl_GetHashValue(hPtr))
- && (cmdPtr->deleteProc == DeleteImportedCmd)) {
- Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ if (hPtr != NULL) {
+ Command *cmdPtr = Tcl_GetHashValue(hPtr);
+
+ if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ }
}
return TCL_OK;
}
@@ -1805,7 +1867,7 @@ Tcl_ForgetImport(
}
origin = firstToken;
}
- if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
+ if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){
Tcl_DeleteCommandFromToken(interp, token);
}
}
@@ -1874,17 +1936,29 @@ TclGetOriginalCommand(
*/
static int
-InvokeImportedCmd(
+InvokeImportedNRCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- register ImportedCmdData *dataPtr = clientData;
- register Command *realCmdPtr = dataPtr->realCmdPtr;
+ ImportedCmdData *dataPtr = clientData;
+ Command *realCmdPtr = dataPtr->realCmdPtr;
- return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
+ ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
+}
+
+static int
+InvokeImportedCmd(
+ ClientData clientData, /* Points to the imported command's
+ * ImportedCmdData structure. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData,
objc, objv);
}
@@ -1933,8 +2007,8 @@ DeleteImportedCmd(
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
- ckfree((char *) refPtr);
- ckfree((char *) dataPtr);
+ ckfree(refPtr);
+ ckfree(dataPtr);
return;
}
prevPtr = refPtr;
@@ -2180,7 +2254,15 @@ TclGetNamespaceForQualName(
*/
if (nsPtr != NULL) {
+#ifndef BREAK_NAMESPACE_COMPAT
entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
+#else
+ if (nsPtr->childTablePtr == NULL) {
+ entryPtr = NULL;
+ } else {
+ entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
+ }
+#endif
if (entryPtr != NULL) {
nsPtr = Tcl_GetHashValue(entryPtr);
} else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
@@ -2189,8 +2271,8 @@ TclGetNamespaceForQualName(
(void) TclPushStackFrame(interp, &framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
- nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
- NULL, NULL);
+ nsPtr = (Namespace *)
+ Tcl_CreateNamespace(interp, nsName, NULL, NULL);
TclPopStackFrame(interp);
if (nsPtr == NULL) {
@@ -2207,7 +2289,15 @@ TclGetNamespaceForQualName(
*/
if (altNsPtr != NULL) {
+#ifndef BREAK_NAMESPACE_COMPAT
entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
+#else
+ if (altNsPtr->childTablePtr != NULL) {
+ entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
+ } else {
+ entryPtr = NULL;
+ }
+#endif
if (entryPtr != NULL) {
altNsPtr = Tcl_GetHashValue(entryPtr);
} else {
@@ -2310,7 +2400,9 @@ Tcl_FindNamespace(
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
- } else if (flags & TCL_LEAVE_ERR_MSG) {
+ }
+
+ if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
@@ -2387,7 +2479,7 @@ Tcl_FindCommand(
Tcl_Command cmd;
if (cxtNsPtr->cmdResProc) {
- result = (*cxtNsPtr->cmdResProc)(interp, name,
+ result = cxtNsPtr->cmdResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
} else {
result = TCL_CONTINUE;
@@ -2395,7 +2487,7 @@ Tcl_FindCommand(
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->cmdResProc) {
- result = (*resPtr->cmdResProc)(interp, name,
+ result = resPtr->cmdResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
}
resPtr = resPtr->nextPtr;
@@ -2550,8 +2642,8 @@ TclResetShadowedCmdRefs(
int found, i;
int trailFront = -1;
int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
- Namespace **trailPtr = (Namespace **)
- TclStackAlloc(interp, trailSize * sizeof(Namespace *));
+ Namespace **trailPtr = TclStackAlloc(interp,
+ trailSize * sizeof(Namespace *));
/*
* Start at the namespace containing the new command, and work up through
@@ -2587,8 +2679,17 @@ TclResetShadowedCmdRefs(
for (i = trailFront; i >= 0; i--) {
trailNsPtr = trailPtr[i];
+#ifndef BREAK_NAMESPACE_COMPAT
hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
trailNsPtr->name);
+#else
+ if (shadowNsPtr->childTablePtr != NULL) {
+ hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
+ trailNsPtr->name);
+ } else {
+ hPtr = NULL;
+ }
+#endif
if (hPtr != NULL) {
shadowNsPtr = Tcl_GetHashValue(hPtr);
} else {
@@ -2616,7 +2717,7 @@ TclResetShadowedCmdRefs(
* for a fresh compilation of every bytecode.
*/
- if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
+ if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){
nsPtr->resolverEpoch++;
}
}
@@ -2630,8 +2731,9 @@ TclResetShadowedCmdRefs(
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
- trailPtr = (Namespace **) TclStackRealloc(interp,
- trailPtr, newSize * sizeof(Namespace *));
+
+ trailPtr = TclStackRealloc(interp, trailPtr,
+ newSize * sizeof(Namespace *));
trailSize = newSize;
}
trailPtr[trailFront] = nsPtr;
@@ -2679,7 +2781,7 @@ TclGetNamespaceFromObj(
* Get the current namespace name.
*/
- NamespaceCurrentCmd(NULL, interp, 2, NULL);
+ NamespaceCurrentCmd(NULL, interp, 1, NULL);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"namespace \"%s\" not found in \"%s\"", name,
Tcl_GetStringResult(interp)));
@@ -2702,22 +2804,22 @@ GetNamespaceFromObj(
if (objPtr->typePtr == &nsNameType) {
/*
- * Check that the ResolvedNsName is still valid; avoid letting the ref
+ * Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
*/
- resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
+ resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
(!refNsPtr || ((interp == refNsPtr->interp) &&
- (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) {
+ (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
}
if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
- resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
+ resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
@@ -2727,139 +2829,25 @@ GetNamespaceFromObj(
/*
*----------------------------------------------------------------------
*
- * Tcl_NamespaceObjCmd --
+ * TclInitNamespaceCmd --
*
- * Invoked to implement the "namespace" command that creates, deletes, or
- * manipulates Tcl namespaces. Handles the following syntax:
- *
- * namespace children ?name? ?pattern?
- * namespace code arg
- * namespace current
- * namespace delete ?name name...?
- * namespace ensemble subcommand ?arg...?
- * namespace eval name arg ?arg...?
- * namespace exists name
- * namespace export ?-clear? ?pattern pattern...?
- * namespace forget ?pattern pattern...?
- * namespace import ?-force? ?pattern pattern...?
- * namespace inscope name arg ?arg...?
- * namespace origin name
- * namespace parent ?name?
- * namespace qualifiers string
- * namespace tail string
- * namespace which ?-command? ?-variable? name
+ * This function is called to create the "namespace" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
- * Returns TCL_OK if the command is successful. Returns TCL_ERROR if
- * anything goes wrong.
+ * Handle for the namespace command, or NULL on failure.
*
* Side effects:
- * Based on the subcommand name (e.g., "import"), this function
- * dispatches to a corresponding function NamespaceXXXCmd defined
- * statically in this file. This function's side effects depend on
- * whatever that subcommand function does. If there is an error, this
- * function returns an error message in the interpreter's result object.
- * Otherwise it may return a result in the interpreter's result object.
+ * none
*
*----------------------------------------------------------------------
*/
-int
-Tcl_NamespaceObjCmd(
- ClientData clientData, /* Arbitrary value passed to cmd. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+Tcl_Command
+TclInitNamespaceCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
{
- static const char *subCmds[] = {
- "children", "code", "current", "delete", "ensemble",
- "eval", "exists", "export", "forget", "import",
- "inscope", "origin", "parent", "path", "qualifiers",
- "tail", "unknown", "upvar", "which", NULL
- };
- enum NSSubCmdIdx {
- NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
- NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
- NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
- NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx
- };
- int index, result;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
- return TCL_ERROR;
- }
-
- /*
- * Return an index reflecting the particular subcommand.
- */
-
- result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
- "option", /*flags*/ 0, (int *) &index);
- if (result != TCL_OK) {
- return result;
- }
-
- switch (index) {
- case NSChildrenIdx:
- result = NamespaceChildrenCmd(clientData, interp, objc, objv);
- break;
- case NSCodeIdx:
- result = NamespaceCodeCmd(clientData, interp, objc, objv);
- break;
- case NSCurrentIdx:
- result = NamespaceCurrentCmd(clientData, interp, objc, objv);
- break;
- case NSDeleteIdx:
- result = NamespaceDeleteCmd(clientData, interp, objc, objv);
- break;
- case NSEnsembleIdx:
- result = NamespaceEnsembleCmd(clientData, interp, objc, objv);
- break;
- case NSEvalIdx:
- result = NamespaceEvalCmd(clientData, interp, objc, objv);
- break;
- case NSExistsIdx:
- result = NamespaceExistsCmd(clientData, interp, objc, objv);
- break;
- case NSExportIdx:
- result = NamespaceExportCmd(clientData, interp, objc, objv);
- break;
- case NSForgetIdx:
- result = NamespaceForgetCmd(clientData, interp, objc, objv);
- break;
- case NSImportIdx:
- result = NamespaceImportCmd(clientData, interp, objc, objv);
- break;
- case NSInscopeIdx:
- result = NamespaceInscopeCmd(clientData, interp, objc, objv);
- break;
- case NSOriginIdx:
- result = NamespaceOriginCmd(clientData, interp, objc, objv);
- break;
- case NSParentIdx:
- result = NamespaceParentCmd(clientData, interp, objc, objv);
- break;
- case NSPathIdx:
- result = NamespacePathCmd(clientData, interp, objc, objv);
- break;
- case NSQualifiersIdx:
- result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
- break;
- case NSTailIdx:
- result = NamespaceTailCmd(clientData, interp, objc, objv);
- break;
- case NSUpvarIdx:
- result = NamespaceUpvarCmd(clientData, interp, objc, objv);
- break;
- case NSUnknownIdx:
- result = NamespaceUnknownCmd(clientData, interp, objc, objv);
- break;
- case NSWhichIdx:
- result = NamespaceWhichCmd(clientData, interp, objc, objv);
- break;
- }
- return result;
+ return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap);
}
/*
@@ -2893,7 +2881,7 @@ NamespaceChildrenCmd(
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
- char *pattern = NULL;
+ const char *pattern = NULL;
Tcl_DString buffer;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
@@ -2903,15 +2891,15 @@ NamespaceChildrenCmd(
* Get a pointer to the specified namespace, or the current namespace.
*/
- if (objc == 2) {
+ if (objc == 1) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- } else if ((objc == 3) || (objc == 4)) {
- if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+ } else if ((objc == 2) || (objc == 3)) {
+ if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){
return TCL_ERROR;
}
nsPtr = (Namespace *) namespacePtr;
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
+ Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?");
return TCL_ERROR;
}
@@ -2920,8 +2908,8 @@ NamespaceChildrenCmd(
*/
Tcl_DStringInit(&buffer);
- if (objc == 4) {
- char *name = TclGetString(objv[3]);
+ if (objc == 3) {
+ const char *name = TclGetString(objv[2]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
@@ -2947,13 +2935,27 @@ NamespaceChildrenCmd(
if (strncmp(pattern, nsPtr->fullName, length) != 0) {
goto searchDone;
}
- if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) {
+ if (
+#ifndef BREAK_NAMESPACE_COMPAT
+ Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
+#else
+ nsPtr->childTablePtr != NULL &&
+ Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
+#endif
+ ) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(pattern, -1));
}
goto searchDone;
}
+#ifndef BREAK_NAMESPACE_COMPAT
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+#else
+ if (nsPtr->childTablePtr == NULL) {
+ goto searchDone;
+ }
+ entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+#endif
while (entryPtr != NULL) {
childNsPtr = Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
@@ -3007,11 +3009,11 @@ NamespaceCodeCmd(
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
- register char *arg;
+ register const char *arg;
int length;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arg");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg");
return TCL_ERROR;
}
@@ -3023,10 +3025,10 @@ NamespaceCodeCmd(
" "namespace" command. [Bug 3202171].
*/
- arg = TclGetStringFromObj(objv[2], &length);
+ arg = TclGetStringFromObj(objv[1], &length);
if (*arg==':' && length > 20
&& strncmp(arg, "::namespace inscope ", 20) == 0) {
- Tcl_SetObjResult(interp, objv[2]);
+ Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -3052,7 +3054,7 @@ NamespaceCodeCmd(
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
- Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
+ Tcl_ListObjAppendElement(interp, listPtr, objv[1]);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
@@ -3088,8 +3090,8 @@ NamespaceCurrentCmd(
{
register Namespace *currNsPtr;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
@@ -3150,11 +3152,11 @@ NamespaceDeleteCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
- char *name;
+ const char *name;
register int i;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?name name...?");
return TCL_ERROR;
}
@@ -3164,11 +3166,11 @@ NamespaceDeleteCmd(
* command line are valid, and report any errors.
*/
- for (i = 2; i < objc; i++) {
+ for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
- || (((Namespace *)namespacePtr)->flags & NS_KILLED)) {
+ || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[i]),
"\" in namespace delete command", NULL);
@@ -3182,7 +3184,7 @@ NamespaceDeleteCmd(
* Okay, now delete each namespace.
*/
- for (i = 2; i < objc; i++) {
+ for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0);
if (namespacePtr) {
@@ -3221,18 +3223,32 @@ NamespaceDeleteCmd(
static int
NamespaceEvalCmd(
+ ClientData clientData, /* Arbitrary value passed to cmd. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
+ objv);
+}
+
+static int
+NRNamespaceEvalCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ Interp *iPtr = (Interp *) interp;
+ CmdFrame *invoker;
+ int word;
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
Tcl_Obj *objPtr;
int result;
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -3241,14 +3257,14 @@ NamespaceEvalCmd(
* namespace object along the way.
*/
- result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
+ result = GetNamespaceFromObj(interp, objv[1], &namespacePtr);
/*
* If the namespace wasn't found, try to create it.
*/
if (result == TCL_ERROR) {
- char *name = TclGetString(objv[2]);
+ const char *name = TclGetString(objv[1]);
namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL);
if (namespacePtr == NULL) {
@@ -3269,20 +3285,24 @@ NamespaceEvalCmd(
return TCL_ERROR;
}
- framePtr->objc = objc;
- framePtr->objv = objv;
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ framePtr->objc = objc;
+ framePtr->objv = objv;
+ } else {
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ }
- if (objc == 4) {
+ if (objc == 3) {
/*
* TIP #280: Make actual argument location available to eval'd script.
*/
- Interp *iPtr = (Interp *) interp;
- CmdFrame* invoker = iPtr->cmdFramePtr;
- int word = 3;
-
- TclArgumentGet (interp, objv[3], &invoker, &word);
- result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
+ objPtr = objv[2];
+ invoker = iPtr->cmdFramePtr;
+ word = 3;
+ TclArgumentGet(interp, objPtr, &invoker, &word);
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -3290,24 +3310,39 @@ NamespaceEvalCmd(
* object when it decrements its refcount after eval'ing it.
*/
- objPtr = Tcl_ConcatObj(objc-3, objv+3);
+ objPtr = Tcl_ConcatObj(objc-2, objv+2);
+ invoker = NULL;
+ word = 0;
+ }
- /*
- * TIP #280: Make invoking context available to eval'd script.
- */
+ /*
+ * TIP #280: Make invoking context available to eval'd script.
+ */
- result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
- }
+ TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
+ NULL, NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
+}
+
+static int
+NsEval_Callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Namespace *namespacePtr = data[0];
if (result == TCL_ERROR) {
int length = strlen(namespacePtr->fullName);
int limit = 200;
int overflow = (length > limit);
+ char *cmd = data[1];
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in namespace eval \"%.*s%s\" script line %d)",
+ "\n (in namespace %s \"%.*s%s\" script line %d)",
+ cmd,
(overflow ? limit : length), namespacePtr->fullName,
- (overflow ? "..." : ""), interp->errorLine));
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
@@ -3348,13 +3383,13 @@ NamespaceExistsCmd(
{
Tcl_Namespace *namespacePtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
- GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK));
+ GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK));
return TCL_OK;
}
@@ -3402,12 +3437,12 @@ NamespaceExportCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- char *pattern, *string;
+ const char *pattern, *string;
int resetListFirst = 0;
int firstArg, patternCt, i, result;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -3415,7 +3450,7 @@ NamespaceExportCmd(
* Process the optional "-clear" argument.
*/
- firstArg = 2;
+ firstArg = 1;
if (firstArg < objc) {
string = TclGetString(objv[firstArg]);
if (strcmp(string, "-clear") == 0) {
@@ -3429,9 +3464,9 @@ NamespaceExportCmd(
* the namespace's current export pattern list.
*/
- patternCt = (objc - firstArg);
+ patternCt = objc - firstArg;
if (patternCt == 0) {
- if (firstArg > 2) {
+ if (firstArg > 1) {
return TCL_OK;
} else {
/*
@@ -3439,6 +3474,7 @@ NamespaceExportCmd(
*/
Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr,
listPtr);
if (result != TCL_OK) {
@@ -3501,15 +3537,15 @@ NamespaceForgetCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *pattern;
+ const char *pattern;
register int i, result;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?");
return TCL_ERROR;
}
- for (i = 2; i < objc; i++) {
+ for (i = 1; i < objc; i++) {
pattern = TclGetString(objv[i]);
result = Tcl_ForgetImport(interp, NULL, pattern);
if (result != TCL_OK) {
@@ -3567,12 +3603,12 @@ NamespaceImportCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowOverwrite = 0;
- char *string, *pattern;
+ const char *string, *pattern;
register int i, result;
int firstArg;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -3580,7 +3616,7 @@ NamespaceImportCmd(
* Skip over the optional "-force" as the first argument.
*/
- firstArg = 2;
+ firstArg = 1;
if (firstArg < objc) {
string = TclGetString(objv[firstArg]);
if ((*string == '-') && (strcmp(string, "-force") == 0)) {
@@ -3589,7 +3625,7 @@ NamespaceImportCmd(
}
} else {
/*
- * When objc == 2, command is just [namespace import]. Introspection
+ * When objc == 1, command is just [namespace import]. Introspection
* form to return list of imported commands.
*/
@@ -3665,6 +3701,17 @@ NamespaceImportCmd(
static int
NamespaceInscopeCmd(
+ ClientData clientData, /* Arbitrary value passed to cmd. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
+ objv);
+}
+
+static int
+NRNamespaceInscopeCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -3672,10 +3719,12 @@ NamespaceInscopeCmd(
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
+ register Interp *iPtr = (Interp *) interp;
int i, result;
+ Tcl_Obj *cmdObjPtr;
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -3683,7 +3732,7 @@ NamespaceInscopeCmd(
* Resolve the namespace reference.
*/
- if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+ if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
@@ -3699,8 +3748,14 @@ NamespaceInscopeCmd(
return result;
}
- framePtr->objc = objc;
- framePtr->objv = objv;
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ framePtr->objc = objc;
+ framePtr->objv = objv;
+ } else {
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ }
/*
* Execute the command. If there is just one argument, just treat it as a
@@ -3709,44 +3764,29 @@ NamespaceInscopeCmd(
* of extra arguments to form the command to evaluate.
*/
- if (objc == 4) {
- result = Tcl_EvalObjEx(interp, objv[3], 0);
+ if (objc == 3) {
+ cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
- register Tcl_Obj *listPtr, *cmdObjPtr;
+ register Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
- for (i = 4; i < objc; i++) {
- if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) {
+ for (i = 3; i < objc; i++) {
+ if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */
return TCL_ERROR;
}
}
- concatObjv[0] = objv[3];
+ concatObjv[0] = objv[2];
concatObjv[1] = listPtr;
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
- result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listPtr); /* We're done with the list object. */
}
- if (result == TCL_ERROR) {
- int length = strlen(namespacePtr->fullName);
- int limit = 200;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in namespace inscope \"%.*s%s\" script line %d)",
- (overflow ? limit : length), namespacePtr->fullName,
- (overflow ? "..." : ""), interp->errorLine));
- }
-
- /*
- * Restore the previous "current" namespace.
- */
-
- TclPopStackFrame(interp);
- return result;
+ TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
+ NULL, NULL);
+ return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
}
/*
@@ -3788,17 +3828,17 @@ NamespaceOriginCmd(
Tcl_Command command, origCommand;
Tcl_Obj *resultPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- command = Tcl_GetCommandFromObj(interp, objv[2]);
+ command = Tcl_GetCommandFromObj(interp, objv[1]);
if (command == NULL) {
Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[2]), "\"", NULL);
+ TclGetString(objv[1]), "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
origCommand = TclGetOriginalCommand(command);
@@ -3848,14 +3888,14 @@ NamespaceParentCmd(
{
Tcl_Namespace *nsPtr;
- if (objc == 2) {
+ if (objc == 1) {
nsPtr = TclGetCurrentNamespace(interp);
- } else if (objc == 3) {
- if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
+ } else if (objc == 2) {
+ if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?name?");
+ Tcl_WrongNumArgs(interp, 1, objv, "?name?");
return TCL_ERROR;
}
@@ -3909,8 +3949,8 @@ NamespacePathCmd(
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?pathList?");
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
return TCL_ERROR;
}
@@ -3918,7 +3958,7 @@ NamespacePathCmd(
* If no path is given, return the current path.
*/
- if (objc == 2) {
+ if (objc == 1) {
/*
* Not a very fast way to compute this, but easy to get right.
*/
@@ -3936,12 +3976,12 @@ NamespacePathCmd(
* There is a path given, so parse it into an array of namespace pointers.
*/
- if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
- namespaceList = (Tcl_Namespace **)
- TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc);
+ namespaceList = TclStackAlloc(interp,
+ sizeof(Tcl_Namespace *) * nsObjc);
for (i=0 ; i<nsObjc ; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
@@ -3992,7 +4032,7 @@ TclSetNsPath(
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
- NamespacePathEntry *tmpPathArray = (NamespacePathEntry *)
+ NamespacePathEntry *tmpPathArray =
ckalloc(sizeof(NamespacePathEntry) * pathLength);
int i;
@@ -4048,6 +4088,7 @@ UnlinkNsPath(
int i;
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
+
if (nsPathPtr->prevPtr != NULL) {
nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
}
@@ -4060,7 +4101,7 @@ UnlinkNsPath(
}
}
}
- ckfree((char *) nsPtr->commandPathArray);
+ ckfree(nsPtr->commandPathArray);
}
/*
@@ -4088,6 +4129,7 @@ TclInvalidateNsPath(
Namespace *nsPtr)
{
NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+
while (nsPathPtr != NULL) {
if (nsPathPtr->nsPtr != NULL) {
nsPathPtr->creatorNsPtr->cmdRefEpoch++;
@@ -4128,11 +4170,11 @@ NamespaceQualifiersCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- register char *name, *p;
+ register const char *name, *p;
int length;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "string");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
@@ -4141,7 +4183,7 @@ NamespaceQualifiersCmd(
* the last "::" qualifier.
*/
- name = TclGetString(objv[2]);
+ name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -4200,14 +4242,14 @@ NamespaceUnknownCmd(
Tcl_Obj *resultPtr;
int rc;
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?script?");
return TCL_ERROR;
}
currNsPtr = TclGetCurrentNamespace(interp);
- if (objc == 2) {
+ if (objc == 1) {
/*
* Introspection - return the current namespace handler.
*/
@@ -4218,9 +4260,9 @@ NamespaceUnknownCmd(
}
Tcl_SetObjResult(interp, resultPtr);
} else {
- rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]);
+ rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]);
if (rc == TCL_OK) {
- Tcl_SetObjResult(interp, objv[2]);
+ Tcl_SetObjResult(interp, objv[1]);
}
return rc;
}
@@ -4251,10 +4293,10 @@ Tcl_GetNamespaceUnknownHandler(
* exists. */
Tcl_Namespace *nsPtr) /* The namespace. */
{
- Namespace *currNsPtr = (Namespace *)nsPtr;
+ Namespace *currNsPtr = (Namespace *) nsPtr;
if (currNsPtr->unknownHandlerPtr == NULL &&
- currNsPtr == ((Interp *)interp)->globalNsPtr) {
+ currNsPtr == ((Interp *) interp)->globalNsPtr) {
/*
* Default handler for global namespace is "::unknown". For all other
* namespaces, it is NULL (which falls back on the global unknown
@@ -4295,7 +4337,7 @@ Tcl_SetNamespaceUnknownHandler(
Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
{
int lstlen = 0;
- Namespace *currNsPtr = (Namespace *)nsPtr;
+ Namespace *currNsPtr = (Namespace *) nsPtr;
/*
* Ensure that we check for errors *first* before we change anything.
@@ -4383,10 +4425,10 @@ NamespaceTailCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- register char *name, *p;
+ register const char *name, *p;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "string");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
@@ -4395,7 +4437,7 @@ NamespaceTailCmd(
* qualifier.
*/
- name = TclGetString(objv[2]);
+ name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -4444,24 +4486,23 @@ NamespaceUpvarCmd(
Interp *iPtr = (Interp *) interp;
Tcl_Namespace *nsPtr, *savedNsPtr;
Var *otherPtr, *arrayPtr;
- char *myName;
+ const char *myName;
- if (objc < 5 || !(objc & 1)) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "ns otherVar myVar ?otherVar myVar ...?");
+ if (objc < 2 || (objc & 1)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?");
return TCL_ERROR;
}
- if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
+ if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
return TCL_ERROR;
}
- objc -= 3;
- objv += 3;
+ objc -= 2;
+ objv += 2;
for (; objc>0 ; objc-=2, objv+=2) {
/*
- * Locate the other variable
+ * Locate the other variable.
*/
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
@@ -4516,22 +4557,22 @@ NamespaceWhichCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *opts[] = {
+ static const char *const opts[] = {
"-command", "-variable", NULL
};
int lookupType = 0;
Tcl_Obj *resultPtr;
- if (objc < 3 || objc > 4) {
+ if (objc < 2 || objc > 3) {
badArgs:
- Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
return TCL_ERROR;
- } else if (objc == 4) {
+ } else if (objc == 3) {
/*
* Look for a flag controlling the lookup.
*/
- if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
+ if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,
&lookupType) != TCL_OK) {
/*
* Preserve old style of error message!
@@ -4590,9 +4631,7 @@ FreeNsNameInternalRep(
register Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- objPtr->internalRep.twoPtrValue.ptr1;
- Namespace *nsPtr;
+ ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Decrement the reference count of the namespace. If there are no more
@@ -4601,19 +4640,14 @@ FreeNsNameInternalRep(
resNamePtr->refCount--;
if (resNamePtr->refCount == 0) {
-
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
* it.
*/
- nsPtr = resNamePtr->nsPtr;
- nsPtr->refCount--;
- if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
- NamespaceFree(nsPtr);
- }
- ckfree((char *) resNamePtr);
+ TclNsDecrRefCount(resNamePtr->nsPtr);
+ ckfree(resNamePtr);
}
objPtr->typePtr = NULL;
}
@@ -4642,8 +4676,7 @@ DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
resNamePtr->refCount++;
@@ -4706,13 +4739,12 @@ SetNsNameFromAny(
if (objPtr->typePtr == &nsNameType) {
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
}
return TCL_ERROR;
}
nsPtr->refCount++;
- resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
+ resNamePtr = ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
@@ -4729,2177 +4761,246 @@ SetNsNameFromAny(
/*
*----------------------------------------------------------------------
*
- * NamespaceEnsembleCmd --
- *
- * Invoked to implement the "namespace ensemble" command that creates and
- * manipulates ensembles built on top of namespaces. Handles the
- * following syntax:
+ * TclGetNamespaceCommandTable --
*
- * namespace ensemble name ?dictionary?
+ * Returns the hash table of commands.
*
* Results:
- * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ * Pointer to the hash table.
*
* Side effects:
- * Creates the ensemble for the namespace if one did not previously
- * exist. Alternatively, alters the way that the ensemble's subcommand =>
- * implementation prefix is configured.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NamespaceEnsembleCmd(
- ClientData dummy,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Namespace *nsPtr;
- Tcl_Command token;
- static const char *subcommands[] = {
- "configure", "create", "exists", NULL
- };
- enum EnsSubcmds {
- ENS_CONFIG, ENS_CREATE, ENS_EXISTS
- };
- static const char *createOptions[] = {
- "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL
- };
- enum EnsCreateOpts {
- CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
- };
- static const char *configOptions[] = {
- "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL
- };
- enum EnsConfigOpts {
- CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN
- };
- int index;
-
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "tried to manipulate ensemble of deleted namespace", NULL);
- }
- return TCL_ERROR;
- }
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum EnsSubcmds) index) {
- case ENS_CREATE: {
- char *name;
- Tcl_DictSearch search;
- Tcl_Obj *listObj;
- int done, len, allocatedMapFlag = 0;
- /*
- * Defaults
- */
- Tcl_Obj *subcmdObj = NULL;
- Tcl_Obj *mapObj = NULL;
- int permitPrefix = 1;
- Tcl_Obj *unknownObj = NULL;
-
- objv += 3;
- objc -= 3;
-
- /*
- * Work out what name to use for the command to create. If supplied,
- * it is either fully specified or relative to the current namespace.
- * If not supplied, it is exactly the name of the current namespace.
- */
-
- name = nsPtr->fullName;
-
- /*
- * Parse the option list, applying type checks as we go. Note that we
- * are not incrementing any reference counts in the objects at this
- * stage, so the presence of an option multiple times won't cause any
- * memory leaks.
- */
-
- for (; objc>1 ; objc-=2,objv+=2 ) {
- if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
- 0, &index) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- switch ((enum EnsCreateOpts) index) {
- case CRT_CMD:
- name = TclGetString(objv[1]);
- continue;
- case CRT_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- subcmdObj = (len > 0 ? objv[1] : NULL);
- continue;
- case CRT_MAP: {
- Tcl_Obj *patchedDict = NULL, *subcmdObj;
-
- /*
- * Verify that the map is sensible.
- */
-
- if (Tcl_DictObjFirst(interp, objv[1], &search,
- &subcmdObj, &listObj, &done) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (done) {
- mapObj = NULL;
- continue;
- }
- do {
- Tcl_Obj **listv;
- char *cmd;
-
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (len < 1) {
- Tcl_SetResult(interp,
- "ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- cmd = TclGetString(listv[0]);
- if (!(cmd[0] == ':' && cmd[1] == ':')) {
- Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
-
- if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
- }
- Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
- if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
- }
- Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
- }
- Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
- } while (!done);
-
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- mapObj = (patchedDict ? patchedDict : objv[1]);
- if (patchedDict) {
- allocatedMapFlag = 1;
- }
- continue;
- }
- case CRT_PREFIX:
- if (Tcl_GetBooleanFromObj(interp, objv[1],
- &permitPrefix) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- continue;
- case CRT_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- unknownObj = (len > 0 ? objv[1] : NULL);
- continue;
- }
- }
-
- /*
- * Create the ensemble. Note that this might delete another ensemble
- * linked to the same namespace, so we must be careful. However, we
- * should be OK because we only link the namespace into the list once
- * we've created it (and after any deletions have occurred.)
- */
-
- token = Tcl_CreateEnsemble(interp, name, NULL,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
- Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
- Tcl_SetEnsembleMappingDict(interp, token, mapObj);
- Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
-
- /*
- * Tricky! Must ensure that the result is not shared (command delete
- * traces could have corrupted the pristine object that we started
- * with). [Snit test rename-1.5]
- */
-
- Tcl_ResetResult(interp);
- Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
- return TCL_OK;
- }
-
- case ENS_EXISTS:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
- Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
- return TCL_OK;
-
- case ENS_CONFIG:
- if (objc < 4 || (objc != 5 && objc & 1)) {
- Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
- return TCL_ERROR;
- }
- token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
- if (token == NULL) {
- return TCL_ERROR;
- }
-
- if (objc == 5) {
- Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
-
- if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum EnsConfigOpts) index) {
- case CONF_SUBCMDS:
- Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
- if (resultObj != NULL) {
- Tcl_SetObjResult(interp, resultObj);
- }
- break;
- case CONF_MAP:
- Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
- if (resultObj != NULL) {
- Tcl_SetObjResult(interp, resultObj);
- }
- break;
- case CONF_NAMESPACE: {
- Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
-
- Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName,
- TCL_VOLATILE);
- break;
- }
- case CONF_PREFIX: {
- int flags = 0; /* silence gcc 4 warning */
-
- Tcl_GetEnsembleFlags(NULL, token, &flags);
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
- break;
- }
- case CONF_UNKNOWN:
- Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
- if (resultObj != NULL) {
- Tcl_SetObjResult(interp, resultObj);
- }
- break;
- }
- return TCL_OK;
-
- } else if (objc == 4) {
- /*
- * Produce list of all information.
- */
-
- Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
- Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
- int flags = 0; /* silence gcc 4 warning */
-
- TclNewObj(resultObj);
-
- /* -map option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_MAP], -1));
- Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- /* -namespace option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
- Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName,
- -1));
-
- /* -prefix option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));
- Tcl_GetEnsembleFlags(NULL, token, &flags);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
-
- /* -subcommands option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
- Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- /* -unknown option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
- Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- } else {
- Tcl_DictSearch search;
- Tcl_Obj *listObj;
- int done, len, allocatedMapFlag = 0;
- Tcl_Obj *subcmdObj = NULL, *mapObj = NULL,
- *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
- int permitPrefix, flags = 0; /* silence gcc 4 warning */
-
- Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
- Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
- Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
- Tcl_GetEnsembleFlags(NULL, token, &flags);
- permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
-
- objv += 4;
- objc -= 4;
-
- /*
- * Parse the option list, applying type checks as we go. Note that
- * we are not incrementing any reference counts in the objects at
- * this stage, so the presence of an option multiple times won't
- * cause any memory leaks.
- */
-
- for (; objc>0 ; objc-=2,objv+=2 ) {
- if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
- "option", 0, &index) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- switch ((enum EnsConfigOpts) index) {
- case CONF_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- subcmdObj = (len > 0 ? objv[1] : NULL);
- continue;
- case CONF_MAP: {
- Tcl_Obj *patchedDict = NULL, *subcmdObj;
-
- /*
- * Verify that the map is sensible.
- */
-
- if (Tcl_DictObjFirst(interp, objv[1], &search,
- &subcmdObj, &listObj, &done) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (done) {
- mapObj = NULL;
- continue;
- }
- do {
- Tcl_Obj **listv;
- char *cmd;
-
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (len < 1) {
- Tcl_SetResult(interp,
- "ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- cmd = TclGetString(listv[0]);
- if (!(cmd[0] == ':' && cmd[1] == ':')) {
- Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd =
- Tcl_NewStringObj(nsPtr->fullName, -1);
- if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
- }
- Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
- if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
- }
- Tcl_DictObjPut(NULL, patchedDict, subcmdObj,
- newList);
- }
- Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
- } while (!done);
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- mapObj = (patchedDict ? patchedDict : objv[1]);
- if (patchedDict) {
- allocatedMapFlag = 1;
- }
- continue;
- }
- case CONF_NAMESPACE:
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- Tcl_AppendResult(interp, "option -namespace is read-only",
- NULL);
- return TCL_ERROR;
- case CONF_PREFIX:
- if (Tcl_GetBooleanFromObj(interp, objv[1],
- &permitPrefix) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- continue;
- case CONF_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- unknownObj = (len > 0 ? objv[1] : NULL);
- continue;
- }
- }
-
- /*
- * Update the namespace now that we've finished the parsing stage.
- */
-
- flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
- : flags&~TCL_ENSEMBLE_PREFIX);
- Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
- Tcl_SetEnsembleMappingDict(interp, token, mapObj);
- Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
- Tcl_SetEnsembleFlags(interp, token, flags);
- return TCL_OK;
- }
-
- default:
- Tcl_Panic("unexpected ensemble command");
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateEnsemble --
- *
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
- *
- * Side effects:
- * The ensemble is created and marked for compilation.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-Tcl_CreateEnsemble(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *namespacePtr,
- int flags)
-{
- Namespace *nsPtr = (Namespace *) namespacePtr;
- EnsembleConfig *ensemblePtr = (EnsembleConfig *)
- ckalloc(sizeof(EnsembleConfig));
- Tcl_Obj *nameObj = NULL;
-
- if (nsPtr == NULL) {
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- }
-
- /*
- * Make the name of the ensemble into a fully qualified name. This might
- * allocate a temporary object.
- */
-
- if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
- if (nsPtr->parentPtr == NULL) {
- Tcl_AppendStringsToObj(nameObj, name, NULL);
- } else {
- Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
- }
- Tcl_IncrRefCount(nameObj);
- name = TclGetString(nameObj);
- }
-
- ensemblePtr->nsPtr = nsPtr;
- ensemblePtr->epoch = 0;
- Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
- ensemblePtr->subcommandArrayPtr = NULL;
- ensemblePtr->subcmdList = NULL;
- ensemblePtr->subcommandDict = NULL;
- ensemblePtr->flags = flags;
- ensemblePtr->unknownHandler = NULL;
- ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
- NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig);
- ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
- nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
-
- /*
- * Trigger an eventual recomputation of the ensemble command set. Note
- * that this is slightly tricky, as it means that we are not actually
- * counting the number of namespace export actions, but it is the simplest
- * way to go!
- */
-
- nsPtr->exportLookupEpoch++;
-
- if (flags & ENSEMBLE_COMPILE) {
- ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
- }
-
- if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
- }
- return ensemblePtr->token;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleSubcommandList --
- *
- * Set the subcommand list for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the subcommand list - if non-NULL - is not a list).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleSubcommandList(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *subcmdList)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldList;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (subcmdList != NULL) {
- int length;
-
- if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
- return TCL_ERROR;
- }
- if (length < 1) {
- subcmdList = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldList = ensemblePtr->subcmdList;
- ensemblePtr->subcmdList = subcmdList;
- if (subcmdList != NULL) {
- Tcl_IncrRefCount(subcmdList);
- }
- if (oldList != NULL) {
- TclDecrRefCount(oldList);
- }
-
- /*
- * Trigger an eventual recomputation of the ensemble command set. Note
- * that this is slightly tricky, as it means that we are not actually
- * counting the number of namespace export actions, but it is the simplest
- * way to go!
- */
-
- ensemblePtr->nsPtr->exportLookupEpoch++;
-
- /*
- * Special hack to make compiling of [info exists] work when the
- * dictionary is modified.
- */
-
- if (cmdPtr->compileProc != NULL) {
- ((Interp *)interp)->compileEpoch++;
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleMappingDict --
- *
- * Set the mapping dictionary for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the mapping - if non-NULL - is not a dict).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleMappingDict(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *mapDict)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldDict;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (mapDict != NULL) {
- int size, done;
- Tcl_DictSearch search;
- Tcl_Obj *valuePtr;
-
- if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
- return TCL_ERROR;
- }
-
- for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
- !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
- Tcl_Obj *cmdPtr;
- const char *bytes;
-
- if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) {
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
- bytes = TclGetString(cmdPtr);
- if (bytes[0] != ':' || bytes[1] != ':') {
- Tcl_AppendResult(interp,
- "ensemble target is not a fully-qualified command",
- NULL);
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
- }
-
- if (size < 1) {
- mapDict = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldDict = ensemblePtr->subcommandDict;
- ensemblePtr->subcommandDict = mapDict;
- if (mapDict != NULL) {
- Tcl_IncrRefCount(mapDict);
- }
- if (oldDict != NULL) {
- TclDecrRefCount(oldDict);
- }
-
- /*
- * Trigger an eventual recomputation of the ensemble command set. Note
- * that this is slightly tricky, as it means that we are not actually
- * counting the number of namespace export actions, but it is the simplest
- * way to go!
- */
-
- ensemblePtr->nsPtr->exportLookupEpoch++;
-
- /*
- * Special hack to make compiling of [info exists] work when the
- * dictionary is modified.
- */
-
- if (cmdPtr->compileProc != NULL) {
- ((Interp *)interp)->compileEpoch++;
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleUnknownHandler --
- *
- * Set the unknown handler for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the unknown handler - if non-NULL - is not a list).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleUnknownHandler(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *unknownList)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldList;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (unknownList != NULL) {
- int length;
-
- if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
- return TCL_ERROR;
- }
- if (length < 1) {
- unknownList = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldList = ensemblePtr->unknownHandler;
- ensemblePtr->unknownHandler = unknownList;
- if (unknownList != NULL) {
- Tcl_IncrRefCount(unknownList);
- }
- if (oldList != NULL) {
- TclDecrRefCount(oldList);
- }
-
- /*
- * Trigger an eventual recomputation of the ensemble command set. Note
- * that this is slightly tricky, as it means that we are not actually
- * counting the number of namespace export actions, but it is the simplest
- * way to go!
- */
-
- ensemblePtr->nsPtr->exportLookupEpoch++;
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleFlags --
- *
- * Set the flags for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleFlags(
- Tcl_Interp *interp,
- Tcl_Command token,
- int flags)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- int wasCompiled;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
-
- /*
- * This API refuses to set the ENS_DEAD flag...
- */
-
- ensemblePtr->flags &= ENS_DEAD;
- ensemblePtr->flags |= flags & ~ENS_DEAD;
-
- /*
- * Trigger an eventual recomputation of the ensemble command set. Note
- * that this is slightly tricky, as it means that we are not actually
- * counting the number of namespace export actions, but it is the simplest
- * way to go!
- */
-
- ensemblePtr->nsPtr->exportLookupEpoch++;
-
- /*
- * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
- * compiler function and bump the interpreter's compilation epoch so that
- * bytecode gets regenerated.
- */
-
- if (flags & ENSEMBLE_COMPILE) {
- if (!wasCompiled) {
- ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
- ((Interp *) interp)->compileEpoch++;
- }
- } else {
- if (wasCompiled) {
- ((Command*) ensemblePtr->token)->compileProc = NULL;
- ((Interp *) interp)->compileEpoch++;
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleSubcommandList --
- *
- * Get the list of subcommands associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The list of subcommands is returned by updating the
- * variable pointed to by the last parameter (NULL if this is to be
- * derived from the mapping dictionary or the associated namespace's
- * exported commands).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleSubcommandList(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **subcmdListPtr)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- }
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- *subcmdListPtr = ensemblePtr->subcmdList;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleMappingDict --
- *
- * Get the command mapping dictionary associated with a particular
- * ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The mapping dict is returned by updating the variable
- * pointed to by the last parameter (NULL if none is installed).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleMappingDict(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **mapDictPtr)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- }
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- *mapDictPtr = ensemblePtr->subcommandDict;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleUnknownHandler --
- *
- * Get the unknown handler associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The unknown handler is returned by updating the variable
- * pointed to by the last parameter (NULL if no handler is installed).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleUnknownHandler(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **unknownListPtr)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- }
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- *unknownListPtr = ensemblePtr->unknownHandler;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleFlags --
- *
- * Get the flags for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The flags are returned by updating the variable pointed to
- * by the last parameter.
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleFlags(
- Tcl_Interp *interp,
- Tcl_Command token,
- int *flagsPtr)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- }
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- *flagsPtr = ensemblePtr->flags;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleNamespace --
- *
- * Get the namespace associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). Namespace is returned by updating the variable pointed to
- * by the last parameter.
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleNamespace(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Namespace **namespacePtrPtr)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- }
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FindEnsemble --
- *
- * Given a command name, get the ensemble token for it, allowing for
- * [namespace import]s. [Bug 1017022]
- *
- * Results:
- * The token for the ensemble command with the given name, or NULL if the
- * command either does not exist or is not an ensemble (when an error
- * message will be written into the interp if thats non-NULL).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-Tcl_FindEnsemble(
- Tcl_Interp *interp, /* Where to do the lookup, and where to write
- * the errors if TCL_LEAVE_ERR_MSG is set in
- * the flags. */
- Tcl_Obj *cmdNameObj, /* Name of command to look up. */
- int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
- * are probably not useful. */
-{
- Command *cmdPtr;
-
- cmdPtr = (Command *)
- Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
- if (cmdPtr == NULL) {
- return NULL;
- }
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- /*
- * Reuse existing infrastructure for following import link chains
- * rather than duplicating it.
- */
-
- cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
-
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
- "\" is not an ensemble command", NULL);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
- TclGetString(cmdNameObj), NULL);
- }
- return NULL;
- }
- }
-
- return (Tcl_Command) cmdPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_IsEnsemble --
- *
- * Simple test for ensemble-hood that takes into account imported
- * ensemble commands as well.
- *
- * Results:
- * Boolean value
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_IsEnsemble(
- Tcl_Command token)
-{
- Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
- return 1;
- }
- cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
- return 0;
- }
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclMakeEnsemble --
- *
- * Create an ensemble from a table of implementation commands. The
- * ensemble will be subject to (limited) compilation if any of the
- * implementation commands are compilable.
- *
- * Results:
- * Handle for the ensemble, or NULL if creation of it fails.
- *
- * Side effects:
- * May advance bytecode compilation epoch.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-TclMakeEnsemble(
- Tcl_Interp *interp,
- const char *name,
- const EnsembleImplMap map[])
-{
- Tcl_Command ensemble; /* The overall ensemble. */
- Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */
- Tcl_DString buf;
-
- tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
- TCL_CREATE_NS_IF_UNKNOWN);
- if (tclNsPtr == NULL) {
- Tcl_Panic("unable to find or create ::tcl namespace!");
- }
- Tcl_DStringInit(&buf);
- Tcl_DStringAppend(&buf, "::tcl::", -1);
- Tcl_DStringAppend(&buf, name, -1);
- tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
- TCL_CREATE_NS_IF_UNKNOWN);
- if (tclNsPtr == NULL) {
- Tcl_Panic("unable to find or create %s namespace!",
- Tcl_DStringValue(&buf));
- }
- ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
- TCL_ENSEMBLE_PREFIX);
- Tcl_DStringAppend(&buf, "::", -1);
- if (ensemble != NULL) {
- Tcl_Obj *mapDict;
- int i, compile = 0;
-
- TclNewObj(mapDict);
- for (i=0 ; map[i].name != NULL ; i++) {
- Tcl_Obj *fromObj, *toObj;
- Command *cmdPtr;
-
- fromObj = Tcl_NewStringObj(map[i].name, -1);
- TclNewStringObj(toObj, Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf));
- Tcl_AppendToObj(toObj, map[i].name, -1);
- Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
- TclGetString(toObj), map[i].proc, NULL, NULL);
- cmdPtr->compileProc = map[i].compileProc;
- compile |= (map[i].compileProc != NULL);
- }
- Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
- if (compile) {
- Tcl_SetEnsembleFlags(interp, ensemble,
- TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
- }
- }
- Tcl_DStringFree(&buf);
-
- return ensemble;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NsEnsembleImplementationCmd --
- *
- * Implements an ensemble of commands (being those exported by a
- * namespace other than the global namespace) as a command with the same
- * (short) name as the namespace in the parent namespace.
- *
- * Results:
- * A standard Tcl result code. Will be TCL_ERROR if the command is not an
- * unambiguous prefix of any command exported by the ensemble's
- * namespace.
- *
- * Side effects:
- * Depends on the command within the namespace that gets executed. If the
- * ensemble itself returns TCL_ERROR, a descriptive error message will be
- * placed in the interpreter's result.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NsEnsembleImplementationCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- EnsembleConfig *ensemblePtr = clientData;
- /* The ensemble itself. */
- Tcl_Obj **tempObjv; /* Space used to construct the list of
- * arguments to pass to the command that
- * implements the ensemble subcommand. */
- int result; /* The result of the subcommand execution. */
- Tcl_Obj *prefixObj; /* An object containing the prefix words of
- * the command that implements the
- * subcommand. */
- Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
- * specified but not yet cached command
- * names. */
- Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
- * target command prefix. */
- int prefixObjc; /* Size of prefixObjv of course! */
- int reparseCount = 0; /* Number of reparses. */
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
- return TCL_ERROR;
- }
-
- restartEnsembleParse:
- if (ensemblePtr->nsPtr->flags & NS_DYING) {
- /*
- * Don't know how we got here, but make things give up quickly.
- */
-
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "ensemble activated for deleted namespace", NULL);
- }
- return TCL_ERROR;
- }
-
- /*
- * Determine if the table of subcommands is right. If so, we can just look
- * up in there and go straight to dispatch.
- */
-
- if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
- /*
- * Table of subcommands is still valid; therefore there might be a
- * valid cache of discovered information which we can reuse. Do the
- * check here, and if we're still valid, we can jump straight to the
- * part where we do the invocation of the subcommand.
- */
-
- if (objv[1]->typePtr == &tclEnsembleCmdType) {
- EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.otherValuePtr;
-
- if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
- ensembleCmd->epoch == ensemblePtr->epoch &&
- ensembleCmd->token == ensemblePtr->token) {
- prefixObj = ensembleCmd->realPrefixObj;
- Tcl_IncrRefCount(prefixObj);
- goto runResultingSubcommand;
- }
- }
- } else {
- BuildEnsembleConfig(ensemblePtr);
- ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
- }
-
- /*
- * Look in the hashtable for the subcommand name; this is the fastest way
- * of all.
- */
-
- hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
- TclGetString(objv[1]));
- if (hPtr != NULL) {
- char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
-
- prefixObj = Tcl_GetHashValue(hPtr);
-
- /*
- * Cache for later in the subcommand object.
- */
-
- MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
- } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
- /*
- * Could not map, no prefixing, go to unknown/error handling.
- */
-
- goto unknownOrAmbiguousSubcommand;
- } else {
- /*
- * If we've not already confirmed the command with the hash as part of
- * building our export table, we need to scan the sorted array for
- * matches.
- */
-
- char *subcmdName; /* Name of the subcommand, or unique prefix of
- * it (will be an error for a non-unique
- * prefix). */
- char *fullName = NULL; /* Full name of the subcommand. */
- int stringLength, i;
- int tableLength = ensemblePtr->subcommandTable.numEntries;
-
- subcmdName = TclGetString(objv[1]);
- stringLength = objv[1]->length;
- for (i=0 ; i<tableLength ; i++) {
- register int cmp = strncmp(subcmdName,
- ensemblePtr->subcommandArrayPtr[i],
- (unsigned) stringLength);
-
- if (cmp == 0) {
- if (fullName != NULL) {
- /*
- * Since there's never the exact-match case to worry about
- * (hash search filters this), getting here indicates that
- * our subcommand is an ambiguous prefix of (at least) two
- * exported subcommands, which is an error case.
- */
-
- goto unknownOrAmbiguousSubcommand;
- }
- fullName = ensemblePtr->subcommandArrayPtr[i];
- } else if (cmp < 0) {
- /*
- * Because we are searching a sorted table, we can now stop
- * searching because we have gone past anything that could
- * possibly match.
- */
-
- break;
- }
- }
- if (fullName == NULL) {
- /*
- * The subcommand is not a prefix of anything, so bail out!
- */
-
- goto unknownOrAmbiguousSubcommand;
- }
- hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
- if (hPtr == NULL) {
- Tcl_Panic("full name %s not found in supposedly synchronized hash",
- fullName);
- }
- prefixObj = Tcl_GetHashValue(hPtr);
-
- /*
- * Cache for later in the subcommand object.
- */
-
- MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
- }
-
- Tcl_IncrRefCount(prefixObj);
- runResultingSubcommand:
-
- /*
- * Do the real work of execution of the subcommand by building an array of
- * objects (note that this is potentially not the same length as the
- * number of arguments to this ensemble command), populating it and then
- * feeding it back through the main command-lookup engine. In theory, we
- * could look up the command in the namespace ourselves, as we already
- * have the namespace in which it is guaranteed to exist, but we don't do
- * that (the cacheing of the command object used should help with that.)
- */
-
- {
- Interp *iPtr = (Interp *) interp;
- int isRootEnsemble;
- Tcl_Obj *copyObj;
-
- /*
- * Get the prefix that we're rewriting to. To do this we need to
- * ensure that the internal representation of the list does not change
- * so that we can safely keep the internal representations of the
- * elements in the list.
- */
-
- copyObj = TclListObjCopy(NULL, prefixObj);
- TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
-
- /*
- * Record what arguments the script sent in so that things like
- * Tcl_WrongNumArgs can give the correct error message.
- */
-
- isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs = 2;
- iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
- } else {
- int ni = iPtr->ensembleRewrite.numInsertedObjs;
-
- if (ni < 2) {
- iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
- iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1;
- } else {
- iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
- }
- }
-
- /*
- * Allocate a workspace and build the list of arguments to pass to the
- * target command in it.
- */
-
- tempObjv = (Tcl_Obj **) TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc));
- memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
- memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
-
- /*
- * Hand off to the target command.
- */
-
- result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
- TCL_EVAL_INVOKE);
-
- /*
- * Clean up.
- */
-
- TclStackFree(interp, tempObjv);
- Tcl_DecrRefCount(copyObj);
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
- }
- }
- Tcl_DecrRefCount(prefixObj);
- return result;
-
- unknownOrAmbiguousSubcommand:
- /*
- * Have not been able to match the subcommand asked for with a real
- * subcommand that we export. See whether a handler has been registered
- * for dealing with this situation. Will only call (at most) once for any
- * particular ensemble invocation.
- */
-
- if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
- int paramc, i;
- Tcl_Obj **paramv, *unknownCmd, *ensObj;
-
- unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
- TclNewObj(ensObj);
- Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
- Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
- for (i=1 ; i<objc ; i++) {
- Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
- }
- TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
- Tcl_Preserve(ensemblePtr);
- Tcl_IncrRefCount(unknownCmd);
- result = Tcl_EvalObjv(interp, paramc, paramv, 0);
- if (result == TCL_OK) {
- prefixObj = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(prefixObj);
- Tcl_DecrRefCount(unknownCmd);
- Tcl_Release(ensemblePtr);
- Tcl_ResetResult(interp);
- if (ensemblePtr->flags & ENS_DEAD) {
- Tcl_DecrRefCount(prefixObj);
- Tcl_SetResult(interp,
- "unknown subcommand handler deleted its ensemble",
- TCL_STATIC);
- return TCL_ERROR;
- }
-
- /*
- * Namespace is still there. Check if the result is a valid list.
- * If it is, and it is non-empty, that list is what we are using
- * as our replacement.
- */
-
- if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
- Tcl_DecrRefCount(prefixObj);
- Tcl_AddErrorInfo(interp, "\n while parsing result of "
- "ensemble unknown subcommand handler");
- return TCL_ERROR;
- }
- if (prefixObjc > 0) {
- goto runResultingSubcommand;
- }
-
- /*
- * Namespace alive & empty result => reparse.
- */
-
- Tcl_DecrRefCount(prefixObj);
- goto restartEnsembleParse;
- }
- if (!Tcl_InterpDeleted(interp)) {
- if (result != TCL_ERROR) {
- char buf[TCL_INTEGER_SPACE];
-
- Tcl_ResetResult(interp);
- Tcl_SetResult(interp,
- "unknown subcommand handler returned bad code: ",
- TCL_STATIC);
- switch (result) {
- case TCL_RETURN:
- Tcl_AppendResult(interp, "return", NULL);
- break;
- case TCL_BREAK:
- Tcl_AppendResult(interp, "break", NULL);
- break;
- case TCL_CONTINUE:
- Tcl_AppendResult(interp, "continue", NULL);
- break;
- default:
- sprintf(buf, "%d", result);
- Tcl_AppendResult(interp, buf, NULL);
- }
- Tcl_AddErrorInfo(interp, "\n result of "
- "ensemble unknown subcommand handler: ");
- Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
- } else {
- Tcl_AddErrorInfo(interp,
- "\n (ensemble unknown subcommand handler)");
- }
- }
- Tcl_DecrRefCount(unknownCmd);
- Tcl_Release(ensemblePtr);
- return TCL_ERROR;
- }
-
- /*
- * We cannot determine what subcommand to hand off to, so generate a
- * (standard) failure message. Note the one odd case compared with
- * standard ensemble-like command, which is where a namespace has no
- * exported commands at all...
- */
-
- Tcl_ResetResult(interp);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
- TclGetString(objv[1]), NULL);
- if (ensemblePtr->subcommandTable.numEntries == 0) {
- Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]),
- "\": namespace ", ensemblePtr->nsPtr->fullName,
- " does not export any commands", NULL);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1]), NULL);
- return TCL_ERROR;
- }
- Tcl_AppendResult(interp, "unknown ",
- (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
- "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
- if (ensemblePtr->subcommandTable.numEntries == 1) {
- Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
- } else {
- int i;
-
- for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
- Tcl_AppendResult(interp,
- ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
- }
- Tcl_AppendResult(interp, "or ",
- ensemblePtr->subcommandArrayPtr[i], NULL);
- }
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1]), NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MakeCachedEnsembleCommand --
- *
- * Cache what we've computed so far; it's not nice to repeatedly copy
- * strings about. Note that to do this, we start by deleting any old
- * representation that there was (though if it was an out of date
- * ensemble rep, we can skip some of the deallocation process.)
- *
- * Results:
- * None
- *
- * Side effects:
- * Alters the internal representation of the first object parameter.
+ * None.
*
*----------------------------------------------------------------------
*/
-static void
-MakeCachedEnsembleCommand(
- Tcl_Obj *objPtr,
- EnsembleConfig *ensemblePtr,
- const char *subcommandName,
- Tcl_Obj *prefixObjPtr)
+Tcl_HashTable *
+TclGetNamespaceCommandTable(
+ Tcl_Namespace *nsPtr)
{
- register EnsembleCmdRep *ensembleCmd;
- int length;
-
- if (objPtr->typePtr == &tclEnsembleCmdType) {
- ensembleCmd = objPtr->internalRep.otherValuePtr;
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- ensembleCmd->nsPtr->refCount--;
- if ((ensembleCmd->nsPtr->refCount == 0)
- && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
- NamespaceFree(ensembleCmd->nsPtr);
- }
- ckfree(ensembleCmd->fullSubcmdName);
- } else {
- /*
- * Kill the old internal rep, and replace it with a brand new one of
- * our own.
- */
-
- TclFreeIntRep(objPtr);
- ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.otherValuePtr = ensembleCmd;
- objPtr->typePtr = &tclEnsembleCmdType;
- }
-
- /*
- * Populate the internal rep.
- */
-
- ensembleCmd->nsPtr = ensemblePtr->nsPtr;
- ensembleCmd->epoch = ensemblePtr->epoch;
- ensembleCmd->token = ensemblePtr->token;
- ensemblePtr->nsPtr->refCount++;
- ensembleCmd->realPrefixObj = prefixObjPtr;
- length = strlen(subcommandName)+1;
- ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
- memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
- Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
+ return &((Namespace *) nsPtr)->cmdTable;
}
/*
*----------------------------------------------------------------------
*
- * DeleteEnsembleConfig --
+ * TclGetNamespaceChildTable --
*
- * Destroys the data structure used to represent an ensemble. This is
- * called when the ensemble's command is deleted (which happens
- * automatically if the ensemble's namespace is deleted.) Maintainers
- * should note that ensembles should be deleted by deleting their
- * commands.
+ * Returns the hash table of child namespaces.
*
* Results:
- * None.
+ * Pointer to the hash table.
*
* Side effects:
- * Memory is (eventually) deallocated.
+ * Might allocate memory.
*
*----------------------------------------------------------------------
*/
-static void
-DeleteEnsembleConfig(
- ClientData clientData)
+Tcl_HashTable *
+TclGetNamespaceChildTable(
+ Tcl_Namespace *nsPtr)
{
- EnsembleConfig *ensemblePtr = clientData;
- Namespace *nsPtr = ensemblePtr->nsPtr;
- Tcl_HashSearch search;
- Tcl_HashEntry *hEnt;
-
- /*
- * Unlink from the ensemble chain if it has not been marked as having been
- * done already.
- */
-
- if (ensemblePtr->next != ensemblePtr) {
- EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
- if (ensPtr == ensemblePtr) {
- nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
- } else {
- while (ensPtr != NULL) {
- if (ensPtr->next == ensemblePtr) {
- ensPtr->next = ensemblePtr->next;
- break;
- }
- ensPtr = ensPtr->next;
- }
- }
- }
-
- /*
- * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
- * whether disaster happened anyway.
- */
-
- ensemblePtr->flags |= ENS_DEAD;
-
- /*
- * Kill the pointer-containing fields.
- */
-
- if (ensemblePtr->subcommandTable.numEntries != 0) {
- ckfree((char *) ensemblePtr->subcommandArrayPtr);
- }
- hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
- while (hEnt != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt);
-
- Tcl_DecrRefCount(prefixObj);
- hEnt = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
- if (ensemblePtr->subcmdList != NULL) {
- Tcl_DecrRefCount(ensemblePtr->subcmdList);
- }
- if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DecrRefCount(ensemblePtr->subcommandDict);
- }
- if (ensemblePtr->unknownHandler != NULL) {
- Tcl_DecrRefCount(ensemblePtr->unknownHandler);
- }
-
- /*
- * Arrange for the structure to be reclaimed. Note that this is complex
- * because we have to make sure that we can react sensibly when an
- * ensemble is deleted during the process of initialising the ensemble
- * (especially the unknown callback.)
- */
-
- Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
+ Namespace *nPtr = (Namespace *) nsPtr;
+#ifndef BREAK_NAMESPACE_COMPAT
+ return &nPtr->childTable;
+#else
+ if (nPtr->childTablePtr == NULL) {
+ nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
+ }
+ return nPtr->childTablePtr;
+#endif
}
/*
*----------------------------------------------------------------------
*
- * BuildEnsembleConfig --
+ * TclLogCommandInfo --
*
- * Create the internal data structures that describe how an ensemble
- * looks, being a hash mapping from the full command name to the Tcl list
- * that describes the implementation prefix words, and a sorted array of
- * all the full command names to allow for reasonably efficient
- * unambiguous prefix handling.
+ * This function is invoked after an error occurs in an interpreter. It
+ * adds information to iPtr->errorInfo/errorStack fields to describe the
+ * command that was being executed when the error occurred. When pc and
+ * tosPtr are non-NULL, conveying a bytecode execution "inner context",
+ * and the offending instruction is suitable, that inner context is
+ * recorded in errorStack.
*
* Results:
* None.
*
* Side effects:
- * Reallocates and rebuilds the hash table and array stored at the
- * ensemblePtr argument. For large ensembles or large namespaces, this is
- * a potentially expensive operation.
+ * Information about the command is added to errorInfo/errorStack and the
+ * line number stored internally in the interpreter is set.
*
*----------------------------------------------------------------------
*/
-static void
-BuildEnsembleConfig(
- EnsembleConfig *ensemblePtr)
+void
+TclLogCommandInfo(
+ Tcl_Interp *interp, /* Interpreter in which to log information. */
+ const char *script, /* First character in script containing
+ * command (must be <= command). */
+ const char *command, /* First character in command that generated
+ * the error. */
+ int length, /* Number of bytes in command (-1 means use
+ * all bytes up to first null byte). */
+ const unsigned char *pc, /* current pc of bytecode execution context */
+ Tcl_Obj **tosPtr) /* current stack of bytecode execution context */
{
- Tcl_HashSearch search; /* Used for scanning the set of commands in
- * the namespace that backs up this
- * ensemble. */
- int i, j, isNew;
- Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
- Tcl_HashEntry *hPtr;
-
- if (hash->numEntries != 0) {
- /*
- * Remove pre-existing table.
- */
-
- Tcl_HashSearch search;
-
- ckfree((char *) ensemblePtr->subcommandArrayPtr);
- hPtr = Tcl_FirstHashEntry(hash, &search);
- while (hPtr != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(prefixObj);
- hPtr = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(hash);
- Tcl_InitHashTable(hash, TCL_STRING_KEYS);
- }
-
- /*
- * See if we've got an export list. If so, we will only export exactly
- * those commands, which may be either implemented by the prefix in the
- * subcommandDict or mapped directly onto the namespace's commands.
- */
-
- if (ensemblePtr->subcmdList != NULL) {
- Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
- int subcmdc;
-
- TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
- &subcmdv);
- for (i=0 ; i<subcmdc ; i++) {
- char *name = TclGetString(subcmdv[i]);
-
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
-
- /*
- * Skip non-unique cases.
- */
-
- if (!isNew) {
- continue;
- }
-
- /*
- * Look in our dictionary (if present) for the command.
- */
-
- if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
- &target);
- if (target != NULL) {
- Tcl_SetHashValue(hPtr, target);
- Tcl_IncrRefCount(target);
- continue;
- }
- }
-
- /*
- * Not there, so map onto the namespace. Note in this case that we
- * do not guarantee that the command is actually there; that is
- * the programmer's responsibility (or [::unknown] of course).
- */
-
- cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
- if (ensemblePtr->nsPtr->parentPtr != NULL) {
- Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
- } else {
- Tcl_AppendStringsToObj(cmdObj, name, NULL);
- }
- cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
- Tcl_SetHashValue(hPtr, cmdPrefixObj);
- Tcl_IncrRefCount(cmdPrefixObj);
- }
- } else if (ensemblePtr->subcommandDict != NULL) {
- /*
- * No subcmd list, but we do have a mapping dictionary so we should
- * use the keys of that. Convert the dictionary's contents into the
- * form required for the ensemble's internal hashtable.
- */
-
- Tcl_DictSearch dictSearch;
- Tcl_Obj *keyObj, *valueObj;
- int done;
-
- Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
- &keyObj, &valueObj, &done);
- while (!done) {
- char *name = TclGetString(keyObj);
+ register const char *p;
+ Interp *iPtr = (Interp *) interp;
+ int overflow, limit = 150;
+ Var *varPtr, *arrayPtr;
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
- Tcl_SetHashValue(hPtr, valueObj);
- Tcl_IncrRefCount(valueObj);
- Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
- }
- } else {
+ if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
- * Discover what commands are actually exported by the namespace.
- * What we have is an array of patterns and a hash table whose keys
- * are the command names exported by the namespace (the contents do
- * not matter here.) We must find out what commands are actually
- * exported by filtering each command in the namespace against each of
- * the patterns in the export list. Note that we use an intermediate
- * hash table to make memory management easier, and because that makes
- * exact matching far easier too.
- *
- * Suggestion for future enhancement: compute the unique prefixes and
- * place them in the hash too, which should make for even faster
- * matching.
+ * Someone else has already logged error information for this command;
+ * we shouldn't add anything more.
*/
- hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
- for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- char *nsCmdName = /* Name of command in namespace. */
- Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
-
- for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
- if (Tcl_StringMatch(nsCmdName,
- ensemblePtr->nsPtr->exportArrayPtr[i])) {
- hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
-
- /*
- * Remember, hash entries have a full reference to the
- * substituted part of the command (as a list) as their
- * content!
- */
-
- if (isNew) {
- Tcl_Obj *cmdObj, *cmdPrefixObj;
-
- TclNewObj(cmdObj);
- Tcl_AppendStringsToObj(cmdObj,
- ensemblePtr->nsPtr->fullName,
- (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
- nsCmdName, NULL);
- cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
- Tcl_SetHashValue(hPtr, cmdPrefixObj);
- Tcl_IncrRefCount(cmdPrefixObj);
- }
- break;
- }
- }
- }
- }
-
- if (hash->numEntries == 0) {
- ensemblePtr->subcommandArrayPtr = NULL;
return;
}
- /*
- * Create a sorted array of all subcommands in the ensemble; hash tables
- * are all very well for a quick look for an exact match, but they can't
- * determine things like whether a string is a prefix of another (not
- * without lots of preparation anyway) and they're no good for when we're
- * generating the error message either.
- *
- * We do this by filling an array with the names (we use the hash keys
- * directly to save a copy, since any time we change the array we change
- * the hash too, and vice versa) and running quicksort over the array.
- */
-
- ensemblePtr->subcommandArrayPtr = (char **)
- ckalloc(sizeof(char *) * hash->numEntries);
+ if (command != NULL) {
+ /*
+ * Compute the line number where the error occurred.
+ */
+
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ if (length < 0) {
+ length = strlen(command);
+ }
+ overflow = (length > limit);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
+ ? "while executing" : "invoked from within"),
+ (overflow ? limit : length), command,
+ (overflow ? "..." : "")));
+
+ varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+ NULL, 0, 0, &arrayPtr);
+ if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
+ /*
+ * Should not happen.
+ */
+
+ return;
+ } else {
+ Tcl_HashEntry *hPtr
+ = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
+ VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+
+ if (tracePtr->traceProc != EstablishErrorInfoTraces) {
+ /*
+ * The most recent trace set on ::errorInfo is not the one the
+ * core itself puts on last. This means some other code is
+ * tracing the variable, and the additional trace(s) might be
+ * write traces that expect the timing of writes to
+ * ::errorInfo that existed Tcl releases before 8.5. To
+ * satisfy that compatibility need, we write the current
+ * -errorinfo value to the ::errorInfo variable.
+ */
+
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
+ TCL_GLOBAL_ONLY);
+ }
+ }
+ }
/*
- * Fill array from both ends as this makes us less likely to end up with
- * performance problems in qsort(), which is good. Note that doing this
- * makes this code much more opaque, but the naive alternatve:
- *
- * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
- * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
- * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
- * }
- *
- * can produce long runs of precisely ordered table entries when the
- * commands in the namespace are declared in a sorted fashion (an ordering
- * some people like) and the hashing functions (or the command names
- * themselves) are fairly unfortunate. By filling from both ends, it
- * requires active malice (and probably a debugger) to get qsort() to have
- * awful runtime behaviour.
+ * TIP #348
*/
- i = 0;
- j = hash->numEntries;
- hPtr = Tcl_FirstHashEntry(hash, &search);
- while (hPtr != NULL) {
- ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
- hPtr = Tcl_NextHashEntry(&search);
- if (hPtr == NULL) {
- break;
- }
- ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
- hPtr = Tcl_NextHashEntry(&search);
- }
- if (hash->numEntries > 1) {
- qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries,
- sizeof(char *), NsEnsembleStringOrder);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NsEnsembleStringOrder --
- *
- * Helper function to compare two pointers to two strings for use with
- * qsort().
- *
- * Results:
- * -1 if the first string is smaller, 1 if the second string is smaller,
- * and 0 if they are equal.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NsEnsembleStringOrder(
- const void *strPtr1,
- const void *strPtr2)
-{
- return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeEnsembleCmdRep --
- *
- * Destroys the internal representation of a Tcl_Obj that has been
- * holding information about a command in an ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is deallocated. If this held the last reference to a
- * namespace's main structure, that main structure will also be
- * destroyed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeEnsembleCmdRep(
- Tcl_Obj *objPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
-
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- ckfree(ensembleCmd->fullSubcmdName);
- ensembleCmd->nsPtr->refCount--;
- if ((ensembleCmd->nsPtr->refCount == 0)
- && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
- NamespaceFree(ensembleCmd->nsPtr);
+ if (Tcl_IsShared(iPtr->errorStack)) {
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
+ }
+ if (iPtr->resetErrorStack) {
+ int len;
+
+ iPtr->resetErrorStack = 0;
+ Tcl_ListObjLength(interp, iPtr->errorStack, &len);
+ /* reset while keeping the list intrep as much as possible */
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ if (pc != NULL) {
+ Tcl_Obj *innerContext;
+
+ innerContext = TclGetInnerContext(interp, pc, tosPtr);
+ if (innerContext != NULL) {
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
+ }
+ } else if (command != NULL) {
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(command, length));
+ }
+ }
+
+ if (!iPtr->framePtr->objc) {
+ /* special frame, nothing to report */
+ } else if (iPtr->varFramePtr != iPtr->framePtr) {
+ /* uplevel case, [lappend errorstack UP $relativelevel] */
+
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+ iPtr->framePtr->level - iPtr->varFramePtr->level));
+ } else if (iPtr->framePtr != iPtr->rootFramePtr) {
+ /* normal case, [lappend errorstack CALL [info level 0]] */
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
+ iPtr->framePtr->objc, iPtr->framePtr->objv));
}
- ckfree((char *) ensembleCmd);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupEnsembleCmdRep --
- *
- * Makes one Tcl_Obj into a copy of another that is a subcommand of an
- * ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is allocated, and the namespace that the ensemble is built on
- * top of gains another reference.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupEnsembleCmdRep(
- Tcl_Obj *objPtr,
- Tcl_Obj *copyPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
- EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
- ckalloc(sizeof(EnsembleCmdRep));
- int length = strlen(ensembleCmd->fullSubcmdName);
-
- copyPtr->typePtr = &tclEnsembleCmdType;
- copyPtr->internalRep.otherValuePtr = ensembleCopy;
- ensembleCopy->nsPtr = ensembleCmd->nsPtr;
- ensembleCopy->epoch = ensembleCmd->epoch;
- ensembleCopy->token = ensembleCmd->token;
- ensembleCopy->nsPtr->refCount++;
- ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
- Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
- ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
- memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
- (unsigned) length+1);
}
/*
*----------------------------------------------------------------------
*
- * StringOfEnsembleCmdRep --
+ * TclErrorStackResetIf --
*
- * Creates a string representation of a Tcl_Obj that holds a subcommand
- * of an ensemble.
+ * The TIP 348 reset/no-bc part of TLCI, for specific use by
+ * TclCompileSyntaxError.
*
* Results:
* None.
*
* Side effects:
- * The object gains a string (UTF-8) representation.
+ * Reset errorstack if it needs be, and in that case remember the
+ * passed-in error message as inner context.
*
*----------------------------------------------------------------------
*/
-
-static void
-StringOfEnsembleCmdRep(
- Tcl_Obj *objPtr)
+void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
- int length = strlen(ensembleCmd->fullSubcmdName);
+ Interp *iPtr = (Interp *) interp;
- objPtr->length = length;
- objPtr->bytes = ckalloc((unsigned) length+1);
- memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
+ if (Tcl_IsShared(iPtr->errorStack)) {
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
+ }
+ if (iPtr->resetErrorStack) {
+ int len;
+
+ iPtr->resetErrorStack = 0;
+ Tcl_ListObjLength(interp, iPtr->errorStack, &len);
+ /* reset while keeping the list intrep as much as possible */
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(msg, length));
+ }
}
/*
@@ -6908,15 +5009,15 @@ StringOfEnsembleCmdRep(
* Tcl_LogCommandInfo --
*
* This function is invoked after an error occurs in an interpreter. It
- * adds information to iPtr->errorInfo field to describe the command that
- * was being executed when the error occurred.
+ * adds information to iPtr->errorInfo/errorStack fields to describe the
+ * command that was being executed when the error occurred.
*
* Results:
* None.
*
* Side effects:
- * Information about the command is added to errorInfo and the line
- * number stored internally in the interpreter is set.
+ * Information about the command is added to errorInfo/errorStack and the
+ * line number stored internally in the interpreter is set.
*
*----------------------------------------------------------------------
*/
@@ -6931,73 +5032,16 @@ Tcl_LogCommandInfo(
int length) /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
{
- register const char *p;
- Interp *iPtr = (Interp *) interp;
- int overflow, limit = 150;
- Var *varPtr, *arrayPtr;
-
- if (iPtr->flags & ERR_ALREADY_LOGGED) {
- /*
- * Someone else has already logged error information for this command;
- * we shouldn't add anything more.
- */
-
- return;
- }
-
- /*
- * Compute the line number where the error occurred.
- */
-
- iPtr->errorLine = 1;
- for (p = script; p != command; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- if (length < 0) {
- length = strlen(command);
- }
- overflow = (length > limit);
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
- ? "while executing" : "invoked from within"),
- (overflow ? limit : length), command, (overflow ? "..." : "")));
-
- varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
- NULL, 0, 0, &arrayPtr);
- if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
- /*
- * Should not happen.
- */
-
- return;
- } else {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
- (char *) varPtr);
- VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
-
- if (tracePtr->traceProc != EstablishErrorInfoTraces) {
- /*
- * The most recent trace set on ::errorInfo is not the one the
- * core itself puts on last. This means some other code is tracing
- * the variable, and the additional trace(s) might be write traces
- * that expect the timing of writes to ::errorInfo that existed
- * Tcl releases before 8.5. To satisfy that compatibility need, we
- * write the current -errorinfo value to the ::errorInfo variable.
- */
-
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
- TCL_GLOBAL_ONLY);
- }
- }
+ TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}
+
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index f85fb7a..a6523fc 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -17,7 +17,14 @@
#include "tclInt.h"
-extern TclStubs tclStubs;
+/*
+ * Module-scope struct of notifier hooks that are checked in the default
+ * notifier functions (for overriding via Tcl_SetNotifier).
+ */
+
+Tcl_NotifierProcs tclNotifierHooks = {
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL
+};
/*
* For each event source (created with Tcl_CreateEventSource) there is a
@@ -88,7 +95,7 @@ TCL_DECLARE_MUTEX(listLock)
*/
static void QueueEvent(ThreadSpecificData *tsdPtr,
- Tcl_Event* evPtr, Tcl_QueuePosition position);
+ Tcl_Event *evPtr, Tcl_QueuePosition position);
/*
*----------------------------------------------------------------------
@@ -126,7 +133,7 @@ TclInitNotifier(void)
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->threadId = threadId;
- tsdPtr->clientData = tclStubs.tcl_InitNotifier();
+ tsdPtr->clientData = Tcl_InitNotifier();
tsdPtr->initialized = 1;
tsdPtr->nextPtr = firstNotifierPtr;
firstNotifierPtr = tsdPtr;
@@ -174,7 +181,7 @@ TclFinalizeNotifier(void)
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
- ckfree((char *) hold);
+ ckfree(hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
@@ -182,9 +189,7 @@ TclFinalizeNotifier(void)
Tcl_MutexLock(&listLock);
- if (tclStubs.tcl_FinalizeNotifier) {
- tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
- }
+ Tcl_FinalizeNotifier(tsdPtr->clientData);
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
@@ -211,9 +216,8 @@ TclFinalizeNotifier(void)
* None.
*
* Side effects:
- * Overstomps part of the stub vector. This relies on hooks added to the
- * default functions in case those are called directly (i.e., not through
- * the stub table.)
+ * Set the tclNotifierHooks global, which is checked in the default
+ * notifier functions.
*
*----------------------------------------------------------------------
*/
@@ -222,16 +226,7 @@ void
Tcl_SetNotifier(
Tcl_NotifierProcs *notifierProcPtr)
{
-#if !defined(__WIN32__) /* UNIX */
- tclStubs.tcl_CreateFileHandler = notifierProcPtr->createFileHandlerProc;
- tclStubs.tcl_DeleteFileHandler = notifierProcPtr->deleteFileHandlerProc;
-#endif
- tclStubs.tcl_SetTimer = notifierProcPtr->setTimerProc;
- tclStubs.tcl_WaitForEvent = notifierProcPtr->waitForEventProc;
- tclStubs.tcl_InitNotifier = notifierProcPtr->initNotifierProc;
- tclStubs.tcl_FinalizeNotifier = notifierProcPtr->finalizeNotifierProc;
- tclStubs.tcl_AlertNotifier = notifierProcPtr->alertNotifierProc;
- tclStubs.tcl_ServiceModeHook = notifierProcPtr->serviceModeHookProc;
+ tclNotifierHooks = *notifierProcPtr;
}
/*
@@ -281,7 +276,7 @@ Tcl_CreateEventSource(
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
+ EventSource *sourcePtr = ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
@@ -302,7 +297,7 @@ Tcl_CreateEventSource(
* None.
*
* Side effects:
- * The given event source is cancelled, so its function will never again
+ * The given event source is canceled, so its function will never again
* be called. If no such source exists, nothing happens.
*
*----------------------------------------------------------------------
@@ -335,7 +330,7 @@ Tcl_DeleteEventSource(
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
- ckfree((char *) sourcePtr);
+ ckfree(sourcePtr);
return;
}
}
@@ -358,7 +353,7 @@ Tcl_DeleteEventSource(
void
Tcl_QueueEvent(
- Tcl_Event* evPtr, /* Event to add to queue. The storage space
+ Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
@@ -367,6 +362,7 @@ Tcl_QueueEvent(
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
QueueEvent(tsdPtr, evPtr, position);
}
@@ -416,7 +412,7 @@ Tcl_ThreadQueueEvent(
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
- ckfree((char *) evPtr);
+ ckfree(evPtr);
}
Tcl_MutexUnlock(&listLock);
}
@@ -520,14 +516,13 @@ QueueEvent(
void
Tcl_DeleteEvents(
Tcl_EventDeleteProc *proc, /* The function to call. */
- ClientData clientData) /* The type-specific data. */
+ ClientData clientData) /* The type-specific data. */
{
Tcl_Event *evPtr; /* Pointer to the event being examined */
Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if
* evPtr designates the first event in the
* queue for the thread. */
- Tcl_Event* hold;
-
+ Tcl_Event *hold;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&(tsdPtr->queueMutex));
@@ -540,7 +535,7 @@ Tcl_DeleteEvents(
prevPtr = NULL;
evPtr = tsdPtr->firstEventPtr;
while (evPtr != NULL) {
- if ((*proc)(evPtr, clientData) == 1) {
+ if (proc(evPtr, clientData) == 1) {
/*
* This event should be deleted. Unlink it.
*/
@@ -568,7 +563,7 @@ Tcl_DeleteEvents(
hold = evPtr;
evPtr = evPtr->nextPtr;
- ckfree((char *) hold);
+ ckfree(hold);
} else {
/*
* Event is to be retained.
@@ -672,7 +667,7 @@ Tcl_ServiceEvent(
*/
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
- result = (*proc)(evPtr, flags);
+ result = proc(evPtr, flags);
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (result) {
@@ -707,7 +702,7 @@ Tcl_ServiceEvent(
}
}
if (evPtr) {
- ckfree((char *) evPtr);
+ ckfree(evPtr);
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
@@ -774,9 +769,7 @@ Tcl_SetServiceMode(
oldMode = tsdPtr->serviceMode;
tsdPtr->serviceMode = mode;
- if (tclStubs.tcl_ServiceModeHook) {
- tclStubs.tcl_ServiceModeHook(mode);
- }
+ Tcl_ServiceModeHook(mode);
return oldMode;
}
@@ -801,7 +794,7 @@ Tcl_SetServiceMode(
void
Tcl_SetMaxBlockTime(
- Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the
+ const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the
* next blocking operation in the event
* tsdPtr-> */
{
@@ -938,7 +931,7 @@ Tcl_DoOneEvent(
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
- (sourcePtr->setupProc)(sourcePtr->clientData, flags);
+ sourcePtr->setupProc(sourcePtr->clientData, flags);
}
}
tsdPtr->inTraversal = 0;
@@ -967,7 +960,7 @@ Tcl_DoOneEvent(
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
- (sourcePtr->checkProc)(sourcePtr->clientData, flags);
+ sourcePtr->checkProc(sourcePtr->clientData, flags);
}
}
@@ -1077,13 +1070,13 @@ Tcl_ServiceAll(void)
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
- (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
+ sourcePtr->setupProc(sourcePtr->clientData, TCL_ALL_EVENTS);
}
}
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
- (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
+ sourcePtr->checkProc(sourcePtr->clientData, TCL_ALL_EVENTS);
}
}
@@ -1136,9 +1129,7 @@ Tcl_ThreadAlert(
Tcl_MutexLock(&listLock);
for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == threadId) {
- if (tclStubs.tcl_AlertNotifier) {
- tclStubs.tcl_AlertNotifier(tsdPtr->clientData);
- }
+ Tcl_AlertNotifier(tsdPtr->clientData);
break;
}
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
new file mode 100644
index 0000000..6ae82d1
--- /dev/null
+++ b/generic/tclOO.c
@@ -0,0 +1,2723 @@
+/*
+ * tclOO.c --
+ *
+ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2011 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Commands in oo::define.
+ */
+
+static const struct {
+ const char *name;
+ Tcl_ObjCmdProc *objProc;
+ int flag;
+} defineCmds[] = {
+ {"constructor", TclOODefineConstructorObjCmd, 0},
+ {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
+ {"destructor", TclOODefineDestructorObjCmd, 0},
+ {"export", TclOODefineExportObjCmd, 0},
+ {"filter", TclOODefineFilterObjCmd, 0},
+ {"forward", TclOODefineForwardObjCmd, 0},
+ {"method", TclOODefineMethodObjCmd, 0},
+ {"mixin", TclOODefineMixinObjCmd, 0},
+ {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
+ {"self", TclOODefineSelfObjCmd, 0},
+ {"superclass", TclOODefineSuperclassObjCmd, 0},
+ {"unexport", TclOODefineUnexportObjCmd, 0},
+ {"variable", TclOODefineVariablesObjCmd, 0},
+ {NULL, NULL, 0}
+}, objdefCmds[] = {
+ {"class", TclOODefineClassObjCmd, 1},
+ {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
+ {"export", TclOODefineExportObjCmd, 1},
+ {"filter", TclOODefineFilterObjCmd, 1},
+ {"forward", TclOODefineForwardObjCmd, 1},
+ {"method", TclOODefineMethodObjCmd, 1},
+ {"mixin", TclOODefineMixinObjCmd, 1},
+ {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+ {"unexport", TclOODefineUnexportObjCmd, 1},
+ {"variable", TclOODefineVariablesObjCmd, 1},
+ {NULL, NULL, 0}
+};
+
+/*
+ * What sort of size of things we like to allocate.
+ */
+
+#define ALLOC_CHUNK 8
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
+static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
+ const char *nsNameStr);
+static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
+ Method *mPtr, Tcl_Obj *namePtr,
+ Method **newMPtrPtr);
+static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
+ Method *mPtr, Tcl_Obj *namePtr);
+static void DeletedDefineNamespace(ClientData clientData);
+static void DeletedObjdefNamespace(ClientData clientData);
+static void DeletedHelpersNamespace(ClientData clientData);
+static int FinalizeAlloc(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeNext(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeObjectCall(ClientData data[],
+ Tcl_Interp *interp, int result);
+static void InitFoundation(Tcl_Interp *interp);
+static void KillFoundation(ClientData clientData,
+ Tcl_Interp *interp);
+static void MyDeleted(ClientData clientData);
+static void ObjectNamespaceDeleted(ClientData clientData);
+static void ObjectRenamedTrace(ClientData clientData,
+ Tcl_Interp *interp, const char *oldName,
+ const char *newName, int flags);
+static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static void SquelchedNsFirst(ClientData clientData);
+
+static int PublicObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PublicNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+/*
+ * Methods in the oo::object and oo::class classes. First, we define a helper
+ * macro that makes building the method type declaration structure a lot
+ * easier. No point in making life harder than it has to be!
+ *
+ * Note that the core methods don't need clone or free proc callbacks.
+ */
+
+#define DCM(name,visibility,proc) \
+ {name,visibility,\
+ {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}
+
+static const DeclaredClassMethod objMethods[] = {
+ DCM("destroy", 1, TclOO_Object_Destroy),
+ DCM("eval", 0, TclOO_Object_Eval),
+ DCM("unknown", 0, TclOO_Object_Unknown),
+ DCM("variable", 0, TclOO_Object_LinkVar),
+ DCM("varname", 0, TclOO_Object_VarName),
+ {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+}, clsMethods[] = {
+ DCM("create", 1, TclOO_Class_Create),
+ DCM("new", 1, TclOO_Class_New),
+ DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
+ {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+};
+
+static char initScript[] =
+ "namespace eval ::oo { variable version " TCLOO_VERSION " };"
+ "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+/* "tcl_findLibrary tcloo $oo::version $oo::version" */
+/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+
+MODULE_SCOPE const TclOOStubs tclOOStubs;
+
+/*
+ * Convenience macro for getting the foundation from an interpreter.
+ */
+
+#define GetFoundation(interp) \
+ ((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInit --
+ *
+ * Called to initialise the OO system within an interpreter.
+ *
+ * Result:
+ * TCL_OK if the setup succeeded. Currently assumed to always work.
+ *
+ * Side effects:
+ * Creates namespaces, commands, several classes and a number of
+ * callbacks. Upon return, the OO system is ready for use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInit(
+ Tcl_Interp *interp) /* The interpreter to install into. */
+{
+ /*
+ * Build the core of the OO system.
+ */
+
+ InitFoundation(interp);
+
+ /*
+ * Run our initialization script and, if that works, declare the package
+ * to be fully provided.
+ */
+
+ if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION,
+ (ClientData) &tclOOStubs);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetFoundation --
+ *
+ * Get a reference to the OO core class system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Foundation *
+TclOOGetFoundation(
+ Tcl_Interp *interp)
+{
+ return GetFoundation(interp);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitFoundation --
+ *
+ * Set up the core of the OO core class system. This is a structure
+ * holding references to the magical bits that need to be known about in
+ * other places, plus the oo::object and oo::class classes.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InitFoundation(
+ Tcl_Interp *interp)
+{
+ static Tcl_ThreadDataKey tsdKey;
+ ThreadLocalData *tsdPtr =
+ Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = ckalloc(sizeof(Foundation));
+ Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+ Tcl_DString buffer;
+ int i;
+
+ /*
+ * Initialize the structure that holds the OO system core. This is
+ * attached to the interpreter via an assocData entry; not very efficient,
+ * but the best we can do without hacking the core more.
+ */
+
+ memset(fPtr, 0, sizeof(Foundation));
+ ((Interp *) interp)->objectFoundation = fPtr;
+ fPtr->interp = interp;
+ fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
+ Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
+ fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
+ DeletedDefineNamespace);
+ fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
+ DeletedObjdefNamespace);
+ fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
+ DeletedHelpersNamespace);
+ fPtr->epoch = 0;
+ fPtr->tsdPtr = tsdPtr;
+ fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
+ fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
+ fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+ Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
+ Tcl_IncrRefCount(fPtr->constructorName);
+ Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
+ TclOONRUpcatch, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
+ TclOOUnknownDefinition, NULL, NULL);
+ namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
+ Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
+ Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
+
+ /*
+ * Create the subcommands in the oo::define and oo::objdefine spaces.
+ */
+
+ Tcl_DStringInit(&buffer);
+ for (i=0 ; defineCmds[i].name ; i++) {
+ Tcl_DStringAppend(&buffer, "::oo::define::", 14);
+ Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
+ Tcl_DStringFree(&buffer);
+ }
+ for (i=0 ; objdefCmds[i].name ; i++) {
+ Tcl_DStringAppend(&buffer, "::oo::objdefine::", 17);
+ Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
+
+ /*
+ * Create the objects at the core of the object system. These need to be
+ * spliced manually.
+ */
+
+ fPtr->objectCls = AllocClass(interp,
+ AllocObject(interp, "::oo::object", NULL));
+ fPtr->classCls = AllocClass(interp,
+ AllocObject(interp, "::oo::class", NULL));
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+ AddRef(fPtr->objectCls->thisPtr);
+ AddRef(fPtr->objectCls);
+
+ /*
+ * Basic method declarations for the core classes.
+ */
+
+ for (i=0 ; objMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
+ }
+ for (i=0 ; clsMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
+ }
+
+ /*
+ * Finish setting up the class of classes by marking the 'new' method as
+ * private; classes, unlike general objects, must have explicit names. We
+ * also need to create the constructor for classes.
+ *
+ * The 0xDeadBeef is a special signal to the errorInfo logger that is used
+ * by constructors that stops it from generating extra error information
+ * that is confusing.
+ */
+
+ namePtr = Tcl_NewStringObj("new", -1);
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+
+ argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+ Tcl_IncrRefCount(argsPtr);
+ bodyPtr = Tcl_NewStringObj(
+ "set script [list ::oo::define [self] $definitionScript];"
+ "lassign [::oo::UpCatch $script] msg opts\n"
+ "if {[dict get $opts -code] == 1} {"
+ " dict set opts -errorline 0xDeadBeef\n"
+ "}\n"
+ "return -options $opts $msg", -1);
+ fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
+ fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
+ Tcl_DecrRefCount(argsPtr);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
+ TclOOInitInfo(interp);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
+ *
+ * Simple helpers used to clear fields of the foundation when they no
+ * longer hold useful information.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeletedDefineNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->defineNs = NULL;
+}
+
+static void
+DeletedObjdefNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->objdefNs = NULL;
+}
+
+static void
+DeletedHelpersNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->helpersNs = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * KillFoundation --
+ *
+ * Delete those parts of the OO core that are not deleted automatically
+ * when the objects and classes themselves are destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+KillFoundation(
+ ClientData clientData, /* Pointer to the OO system foundation
+ * structure. */
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->objectCls);
+ Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
+ Tcl_DecrRefCount(fPtr->constructorName);
+ Tcl_DecrRefCount(fPtr->destructorName);
+ ckfree(fPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocObject --
+ *
+ * Allocate an object of basic type. Does not splice the object into its
+ * class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Object *
+AllocObject(
+ Tcl_Interp *interp, /* Interpreter within which to create the
+ * object. */
+ const char *nameStr, /* The name of the object to create, or NULL
+ * if the OO system should pick the object
+ * name itself (equal to the namespace
+ * name). */
+ const char *nsNameStr) /* The name of the namespace to create, or
+ * NULL if the OO system should pick a unique
+ * name itself. If this is non-NULL but names
+ * a namespace that already exists, the effect
+ * will be the same as if this was NULL. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+ Command *cmdPtr;
+ CommandTrace *tracePtr;
+ int creationEpoch, ignored;
+
+ oPtr = ckalloc(sizeof(Object));
+ memset(oPtr, 0, sizeof(Object));
+
+ /*
+ * Every object has a namespace; make one. Note that this also normally
+ * computes the creation epoch value for the object, a sequence number
+ * that is unique to the object (and which allows us to manage method
+ * caching without comparing pointers).
+ *
+ * When creating a namespace, we first check to see if the caller
+ * specified the name for the namespace. If not, we generate namespace
+ * names using the epoch until such time as a new namespace is actually
+ * created.
+ */
+
+ if (nsNameStr != NULL) {
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr,
+ ObjectNamespaceDeleted);
+ if (oPtr->namespacePtr != NULL) {
+ creationEpoch = ++fPtr->tsdPtr->nsCount;
+ goto configNamespace;
+ }
+ Tcl_ResetResult(interp);
+ }
+
+ while (1) {
+ char objName[10 + TCL_INTEGER_SPACE];
+
+ sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
+ ObjectNamespaceDeleted);
+ if (oPtr->namespacePtr != NULL) {
+ creationEpoch = fPtr->tsdPtr->nsCount;
+ break;
+ }
+
+ /*
+ * Could not make that namespace, so we make another. But first we
+ * have to get rid of the error message from Tcl_CreateNamespace,
+ * since that's something that should not be exposed to the user.
+ */
+
+ Tcl_ResetResult(interp);
+ }
+
+ /*
+ * Make the namespace know about the helper commands. This grants access
+ * to the [self] and [next] commands.
+ */
+
+ configNamespace:
+ if (fPtr->helpersNs != NULL) {
+ TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+ }
+ TclOOSetupVariableResolver(oPtr->namespacePtr);
+
+ /*
+ * Suppress use of compiled versions of the commands in this object's
+ * namespace and its children; causes wrong behaviour without expensive
+ * recompilation. [Bug 2037727]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
+
+ /*
+ * Set up a callback to get notification of the deletion of a namespace
+ * when enough of the namespace still remains to execute commands and
+ * access variables in it. [Bug 2950259]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+
+ /*
+ * Fill in the rest of the non-zero/NULL parts of the structure.
+ */
+
+ oPtr->fPtr = fPtr;
+ oPtr->selfCls = fPtr->objectCls;
+ oPtr->creationEpoch = creationEpoch;
+ oPtr->refCount = 1;
+ oPtr->flags = USE_CLASS_CACHE;
+
+ /*
+ * Finally, create the object commands and initialize the trace on the
+ * public command (so that the object structures are deleted when the
+ * command is deleted).
+ */
+
+ if (!nameStr) {
+ oPtr->command = Tcl_CreateObjCommand(interp,
+ oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
+ } else if (nameStr[0] == ':' && nameStr[1] == ':') {
+ oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
+ PublicObjectCmd, oPtr, NULL);
+ } else {
+ Tcl_DString buffer;
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer,
+ Tcl_GetCurrentNamespace(interp)->fullName, -1);
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, nameStr, -1);
+ oPtr->command = Tcl_CreateObjCommand(interp,
+ Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ /*
+ * Add the NRE command and trace directly. While this breaks a number of
+ * abstractions, it is faster and we're inside Tcl here so we're allowed.
+ */
+
+ cmdPtr = (Command *) oPtr->command;
+ cmdPtr->nreProc = PublicNRObjectCmd;
+ cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
+ tracePtr->traceProc = ObjectRenamedTrace;
+ tracePtr->clientData = oPtr;
+ tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
+ tracePtr->nextPtr = NULL;
+ tracePtr->refCount = 1;
+
+ /*
+ * Access the namespace command table directly when creating "my" to avoid
+ * a bottleneck in string manipulation. Another abstraction-buster.
+ */
+
+ cmdPtr = ckalloc(sizeof(Command));
+ memset(cmdPtr, 0, sizeof(Command));
+ cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
+ cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
+ &ignored);
+ cmdPtr->refCount = 1;
+ cmdPtr->objProc = PrivateObjectCmd;
+ cmdPtr->deleteProc = MyDeleted;
+ cmdPtr->objClientData = cmdPtr->deleteData = oPtr;
+ cmdPtr->proc = TclInvokeObjectCommand;
+ cmdPtr->clientData = cmdPtr;
+ cmdPtr->nreProc = PrivateNRObjectCmd;
+ Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
+ oPtr->myCommand = (Tcl_Command) cmdPtr;
+
+ return oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MyDeleted --
+ *
+ * This callback is triggered when the object's [my] command is deleted
+ * by any mechanism. It just marks the object as not having a [my]
+ * command, and so prevents cleanup of that when the object itself is
+ * deleted.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+MyDeleted(
+ ClientData clientData) /* Reference to the object whose [my] has been
+ * squelched. */
+{
+ register Object *oPtr = clientData;
+
+ oPtr->myCommand = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SquelchedNsFirst --
+ *
+ * This callback is triggered when the object's namespace is deleted by
+ * any mechanism. It deletes the object's public command if it has not
+ * already been deleted, so ensuring that destructors get run at an
+ * appropriate time. [Bug 2950259]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+SquelchedNsFirst(
+ ClientData clientData)
+{
+ Object *oPtr = clientData;
+
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectRenamedTrace --
+ *
+ * This callback is triggered when the object is deleted by any
+ * mechanism. It runs the destructors and arranges for the actual cleanup
+ * of the object's namespace, which in turn triggers cleansing of the
+ * object data structures.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectRenamedTrace(
+ ClientData clientData, /* The object being deleted. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ const char *oldName, /* What the object was (last) called. */
+ const char *newName, /* Always NULL. */
+ int flags) /* Why was the object deleted? */
+{
+ Object *oPtr = clientData;
+ Class *clsPtr;
+ CallContext *contextPtr;
+
+ /*
+ * If this is a rename and not a delete of the object, we just flush the
+ * cache of the object name.
+ */
+
+ if (flags & TCL_TRACE_RENAME) {
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+ return;
+ }
+
+ /*
+ * Oh dear, the object really is being deleted. Handle this by running the
+ * destructors and deleting the object's namespace, which in turn causes
+ * the real object structures to be deleted.
+ *
+ * Note that it is possible for the namespace to be deleted before the
+ * command. Because of that case, we must take care here to mark the
+ * command as being deleted so that if we return here we don't run into
+ * reentrancy problems.
+ *
+ * We also do not run destructors on the core class objects when the
+ * interpreter is being deleted; their incestuous nature causes problems
+ * in that case when the destructor is partially deleted before the uses
+ * of it have gone. [Bug 2949397]
+ */
+
+ AddRef(oPtr);
+ oPtr->command = NULL;
+ oPtr->flags |= OBJECT_DELETED;
+
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
+ || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ oPtr->flags |= DESTRUCTOR_CALLED;
+ if (contextPtr != NULL) {
+ int result;
+ Tcl_InterpState state;
+
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
+ contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundError(interp);
+ }
+ Tcl_RestoreInterpState(interp, state);
+ TclOODeleteContext(contextPtr);
+ }
+ }
+
+ /*
+ * OK, the destructor's been run. Time to splat the class data (if any)
+ * and nuke the namespace (which triggers the final crushing of the object
+ * structure itself).
+ *
+ * The class of classes needs some special care; if it is deleted (and
+ * we're not killing the whole interpreter) we force the delete of the
+ * class of objects now as well. Due to the incestuous nature of those two
+ * classes, if one goes the other must too and yet the tangle can
+ * sometimes not go away automatically; we force it here. [Bug 2962664]
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
+ Tcl_DeleteCommandFromToken(interp,
+ oPtr->fPtr->classCls->thisPtr->command);
+ } else if (oPtr->flags & ROOT_CLASS) {
+ oPtr->fPtr->classCls = NULL;
+ }
+ }
+
+ clsPtr = oPtr->classPtr;
+ if (clsPtr != NULL) {
+ AddRef(clsPtr);
+ ReleaseClassContents(interp, oPtr);
+ }
+
+ /*
+ * The namespace is only deleted if it hasn't already been deleted. [Bug
+ * 2950259]
+ */
+
+ if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ }
+ if (clsPtr) {
+ DelRef(clsPtr);
+ }
+ DelRef(oPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ReleaseClassContents --
+ *
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ReleaseClassContents(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
+{
+ int i, n;
+ Class *clsPtr = oPtr->classPtr, **list;
+ Object **insts;
+
+ /*
+ * Must empty list before processing the members of the list so that
+ * things happen in the correct order even if something tries to play
+ * fast-and-loose.
+ */
+
+ list = clsPtr->mixinSubs.list;
+ n = clsPtr->mixinSubs.num;
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ clsPtr->mixinSubs.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(list[i]);
+ AddRef(list[i]->thisPtr);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
+ list[i]->thisPtr->flags |= OBJECT_DELETED;
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ DelRef(list[i]->thisPtr);
+ DelRef(list[i]);
+ }
+ if (list != NULL) {
+ ckfree(list);
+ }
+
+ list = clsPtr->subclasses.list;
+ n = clsPtr->subclasses.num;
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
+ clsPtr->subclasses.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(list[i]);
+ AddRef(list[i]->thisPtr);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
+ list[i]->thisPtr->flags |= OBJECT_DELETED;
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ DelRef(list[i]->thisPtr);
+ DelRef(list[i]);
+ }
+ if (list != NULL) {
+ ckfree(list);
+ }
+
+ insts = clsPtr->instances.list;
+ n = clsPtr->instances.num;
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ clsPtr->instances.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(insts[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(insts[i]->flags & OBJECT_DELETED)) {
+ insts[i]->flags |= OBJECT_DELETED;
+ Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+ }
+ DelRef(insts[i]);
+ }
+ if (insts != NULL) {
+ ckfree(insts);
+ }
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ clsPtr->constructorChainPtr = NULL;
+ }
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ clsPtr->destructorChainPtr = NULL;
+ }
+ if (clsPtr->classChainCache) {
+ FOREACH_HASH_DECLS;
+ CallChain *callPtr;
+
+ FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
+ TclOODeleteChain(callPtr);
+ }
+ Tcl_DeleteHashTable(clsPtr->classChainCache);
+ ckfree(clsPtr->classChainCache);
+ clsPtr->classChainCache = NULL;
+ }
+
+ if (clsPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ ckfree(clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+
+
+ if (clsPtr->metadataPtr != NULL) {
+ FOREACH_HASH_DECLS;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree(clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectNamespaceDeleted --
+ *
+ * Callback when the object's namespace is deleted. Used to clean up the
+ * data structures associated with the object. The complicated bit is
+ * that this can sometimes happen before the object's command is deleted
+ * (interpreter teardown is complex!)
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectNamespaceDeleted(
+ ClientData clientData) /* Pointer to the class whose namespace is
+ * being deleted. */
+{
+ Object *oPtr = clientData;
+ FOREACH_HASH_DECLS;
+ Class *clsPtr = oPtr->classPtr, *mixinPtr;
+ Method *mPtr;
+ Tcl_Obj *filterObj, *variableObj;
+ int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ * Also delete the commands that refer to the object at this point (if
+ * they still exist) because otherwise their references to the object
+ * point into freed memory, allowing crashes.
+ */
+
+ oPtr->flags |= OBJECT_DELETED;
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ }
+ if (oPtr->myCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
+ }
+ if (preserved) {
+ AddRef(oPtr);
+ if (clsPtr != NULL) {
+ AddRef(clsPtr);
+ ReleaseClassContents(NULL, oPtr);
+ }
+ }
+
+ /*
+ * Splice the object out of its context. After this, we must *not* call
+ * methods on the object.
+ */
+
+ if (!(oPtr->flags & ROOT_OBJECT)) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ if (i) {
+ ckfree(oPtr->mixins.list);
+ }
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree(oPtr->filters.list);
+ }
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(oPtr->methodsPtr);
+ ckfree(oPtr->methodsPtr);
+ }
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree(oPtr->variables.list);
+ }
+
+ if (oPtr->chainCache) {
+ TclOODeleteChainCache(oPtr->chainCache);
+ }
+
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(oPtr->metadataPtr);
+ ckfree(oPtr->metadataPtr);
+ oPtr->metadataPtr = NULL;
+ }
+
+ if (clsPtr != NULL) {
+ Class *superPtr;
+
+ if (clsPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree(clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree(clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ }
+ if (i) {
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.num = 0;
+ }
+ FOREACH(superPtr, clsPtr->superclasses) {
+ if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
+ }
+ }
+ if (i) {
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ }
+ if (clsPtr->subclasses.list) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.num = 0;
+ }
+ if (clsPtr->instances.list) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.num = 0;
+ }
+ if (clsPtr->mixinSubs.list) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.num = 0;
+ }
+
+ FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(&clsPtr->classMethods);
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree(clsPtr->variables.list);
+ }
+
+ DelRef(clsPtr);
+ }
+
+ /*
+ * Delete the object structure itself.
+ */
+
+ DelRef(oPtr);
+ if (preserved) {
+ if (clsPtr) {
+ DelRef(clsPtr);
+ }
+ DelRef(oPtr);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromInstances --
+ *
+ * Utility function to remove an object from the list of instances within
+ * a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromInstances(
+ Object *oPtr, /* The instance to remove. */
+ Class *clsPtr) /* The class (possibly) containing the
+ * reference to the instance. */
+{
+ int i;
+ Object *instPtr;
+
+ FOREACH(instPtr, clsPtr->instances) {
+ if (oPtr == instPtr) {
+ goto removeInstance;
+ }
+ }
+ return;
+
+ removeInstance:
+ clsPtr->instances.num--;
+ if (i < clsPtr->instances.num) {
+ clsPtr->instances.list[i] =
+ clsPtr->instances.list[clsPtr->instances.num];
+ }
+ clsPtr->instances.list[clsPtr->instances.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToInstances --
+ *
+ * Utility function to add an object to the list of instances within a
+ * class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToInstances(
+ Object *oPtr, /* The instance to add. */
+ Class *clsPtr) /* The class to add the instance to. It is
+ * assumed that the class is not already
+ * present as an instance in the class. */
+{
+ if (clsPtr->instances.num >= clsPtr->instances.size) {
+ clsPtr->instances.size += ALLOC_CHUNK;
+ if (clsPtr->instances.size == ALLOC_CHUNK) {
+ clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+ } else {
+ clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
+ sizeof(Object *) * clsPtr->instances.size);
+ }
+ }
+ clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromSubclasses --
+ *
+ * Utility function to remove a class from the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromSubclasses(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->subclasses) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ superPtr->subclasses.num--;
+ if (i < superPtr->subclasses.num) {
+ superPtr->subclasses.list[i] =
+ superPtr->subclasses.list[superPtr->subclasses.num];
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToSubclasses --
+ *
+ * Utility function to add a class to the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToSubclasses(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (superPtr->subclasses.num >= superPtr->subclasses.size) {
+ superPtr->subclasses.size += ALLOC_CHUNK;
+ if (superPtr->subclasses.size == ALLOC_CHUNK) {
+ superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
+ } else {
+ superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
+ sizeof(Class *) * superPtr->subclasses.size);
+ }
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixinSubs --
+ *
+ * Utility function to remove a class from the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromMixinSubs(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->mixinSubs) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ superPtr->mixinSubs.num--;
+ if (i < superPtr->mixinSubs.num) {
+ superPtr->mixinSubs.list[i] =
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToMixinSubs --
+ *
+ * Utility function to add a class to the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToMixinSubs(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
+ superPtr->mixinSubs.size += ALLOC_CHUNK;
+ if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
+ superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
+ sizeof(Class *) * superPtr->mixinSubs.size);
+ }
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocClass --
+ *
+ * Allocate a basic class. Does not splice the class object into its
+ * class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Class *
+AllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation, or NULL if a new object
+ * (with automatic name) is to be used. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Class *clsPtr = ckalloc(sizeof(Class));
+
+ /*
+ * Make an object if we haven't been given one.
+ */
+
+ memset(clsPtr, 0, sizeof(Class));
+ if (useThisObj == NULL) {
+ clsPtr->thisPtr = AllocObject(interp, NULL, NULL);
+ } else {
+ clsPtr->thisPtr = useThisObj;
+ }
+
+ /*
+ * Configure the namespace path for the class's object.
+ */
+
+ if (fPtr->helpersNs != NULL) {
+ Tcl_Namespace *path[2];
+
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+ } else {
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
+ &fPtr->ooNs);
+ }
+
+ /*
+ * Class objects inherit from the class of classes unless they inherit
+ * from some subclass of it. Enforce this right now.
+ */
+
+ clsPtr->thisPtr->selfCls = fPtr->classCls;
+
+ /*
+ * Classes are subclasses of oo::object, i.e. the objects they create are
+ * objects.
+ */
+
+ clsPtr->superclasses.num = 1;
+ clsPtr->superclasses.list = ckalloc(sizeof(Class *));
+ clsPtr->superclasses.list[0] = fPtr->objectCls;
+
+ /*
+ * Finish connecting the class structure to the object structure.
+ */
+
+ clsPtr->thisPtr->classPtr = clsPtr;
+
+ /*
+ * That's the complicated bit. Now fill in the rest of the non-zero/NULL
+ * fields.
+ */
+
+ clsPtr->refCount = 1;
+ Tcl_InitObjHashTable(&clsPtr->classMethods);
+ return clsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewObjectInstance --
+ *
+ * Allocate a new instance of an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_NewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *nameStr, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ const char *nsNameStr, /* Name of namespace to create inside object,
+ * or NULL to ask the code to pick its own
+ * unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip) /* Number of arguments to _not_ pass to the
+ * constructor. */
+{
+ register Class *classPtr = (Class *) cls;
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+
+ /*
+ * Check if we're going to create an object over an existing command;
+ * that's not allowed.
+ */
+
+ if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
+ TCL_NAMESPACE_ONLY)) {
+ Tcl_AppendResult(interp, "can't create object \"", nameStr,
+ "\": command already exists with that name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ return NULL;
+ }
+
+ /*
+ * Create the object.
+ */
+
+ oPtr = AllocObject(interp, nameStr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ }
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only).
+ */
+
+ if (objc >= 0) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+
+ if (contextPtr != NULL) {
+ int result, flags;
+ Tcl_InterpState state;
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
+ objc, objv);
+ flags = oPtr->flags;
+
+ /*
+ * It's an error if the object was whacked in the constructor.
+ * Force this if it isn't already an error (don't want to lose
+ * errors by accident...) [Bug 2903011]
+ */
+
+ if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ Tcl_SetResult(interp, "object deleted in constructor",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ result = TCL_ERROR;
+ }
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+
+ /*
+ * Take care to not delete a deleted object; that would be
+ * bad. [Bug 2903011]
+ */
+
+ if (!(flags & OBJECT_DELETED)) {
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ return NULL;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ }
+ }
+
+ return (Tcl_Object) oPtr;
+}
+
+int
+TclNRNewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *nameStr, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ const char *nsNameStr, /* Name of namespace to create inside object,
+ * or NULL to ask the code to pick its own
+ * unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip, /* Number of arguments to _not_ pass to the
+ * constructor. */
+ Tcl_Object *objectPtr) /* Place to write the object reference upon
+ * successful allocation. */
+{
+ register Class *classPtr = (Class *) cls;
+ Foundation *fPtr = GetFoundation(interp);
+ CallContext *contextPtr;
+ Tcl_InterpState state;
+ Object *oPtr;
+
+ /*
+ * Check if we're going to create an object over an existing command;
+ * that's not allowed.
+ */
+
+ if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
+ TCL_NAMESPACE_ONLY)) {
+ Tcl_AppendResult(interp, "can't create object \"", nameStr,
+ "\": command already exists with that name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create the object.
+ */
+
+ oPtr = AllocObject(interp, nameStr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ }
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only). If there aren't any constructors, we do nothing.
+ */
+
+ if (objc < 0) {
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+ }
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ if (contextPtr == NULL) {
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+ }
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Fire off the constructors non-recursively.
+ */
+
+ TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
+ objectPtr);
+ TclPushTailcallPoint(interp);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeAlloc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+ Object *oPtr = data[1];
+ Tcl_InterpState state = data[2];
+ Tcl_Object *objectPtr = data[3];
+ int flags = oPtr->flags;
+
+ /*
+ * It's an error if the object was whacked in the constructor. Force this
+ * if it isn't already an error (don't want to lose errors by accident...)
+ * [Bug 2903011]
+ */
+
+ if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ result = TCL_ERROR;
+ }
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+
+ /*
+ * Take care to not delete a deleted object; that would be bad. [Bug
+ * 2903011]
+ */
+
+ if (!(flags & OBJECT_DELETED)) {
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_CopyObjectInstance --
+ *
+ * Creates a copy of an object. Does not copy the backing namespace,
+ * since the correct way to do that (e.g., shallow/deep) depends on the
+ * object/class's own policies.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_CopyObjectInstance(
+ Tcl_Interp *interp,
+ Tcl_Object sourceObject,
+ const char *targetName,
+ const char *targetNamespaceName)
+{
+ Object *oPtr = (Object *) sourceObject, *o2Ptr;
+ FOREACH_HASH_DECLS;
+ Method *mPtr;
+ Class *mixinPtr;
+ Tcl_Obj *keyPtr, *filterObj;
+ int i;
+
+ /*
+ * Sanity checks.
+ */
+
+ if (targetName == NULL && oPtr->classPtr != NULL) {
+ Tcl_AppendResult(interp, "must supply a name when copying a class",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
+ return NULL;
+ }
+ if (oPtr->flags & ROOT_CLASS) {
+ Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
+ return NULL;
+ }
+
+ /*
+ * Build the instance. Note that this does not run any constructors.
+ */
+
+ o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
+ (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1,
+ NULL, -1);
+ if (o2Ptr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Copy the object-local methods to the new object.
+ */
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) {
+ if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ }
+
+ /*
+ * Copy the object's mixin references to the new object.
+ */
+
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ }
+ DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr != o2Ptr->selfCls) {
+ TclOOAddToInstances(o2Ptr, mixinPtr);
+ }
+ }
+
+ /*
+ * Copy the object's filter list to the new object.
+ */
+
+ DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, o2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Copy the object's flags to the new object, clearing those that must be
+ * kept object-local. The duplicate is never deleted at this point, nor is
+ * it the root of the object system or in the midst of processing a filter
+ * call.
+ */
+
+ o2Ptr->flags = oPtr->flags & ~(
+ OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+
+ /*
+ * Copy the object's metadata.
+ */
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ duplicate = value;
+ } else {
+ if (metadataTypePtr->cloneProc(interp, value,
+ &duplicate) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (duplicate != NULL) {
+ Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+
+ /*
+ * Copy the class, if present. Note that if there is a class present in
+ * the source object, there must also be one in the copy.
+ */
+
+ if (oPtr->classPtr != NULL) {
+ Class *clsPtr = oPtr->classPtr;
+ Class *cls2Ptr = o2Ptr->classPtr;
+ Class *superPtr;
+
+ /*
+ * Copy the class flags across.
+ */
+
+ cls2Ptr->flags = clsPtr->flags;
+
+ /*
+ * Ensure that the new class's superclass structure is the same as the
+ * old class's.
+ */
+
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+ }
+ if (cls2Ptr->superclasses.num) {
+ cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ } else {
+ cls2Ptr->superclasses.list =
+ ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
+ }
+ memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ cls2Ptr->superclasses.num = clsPtr->superclasses.num;
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOOAddToSubclasses(cls2Ptr, superPtr);
+ }
+
+ /*
+ * Duplicate the source class's filters.
+ */
+
+ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, cls2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Duplicate the source class's mixins (which cannot be circular
+ * references to the duplicate).
+ */
+
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ }
+ if (cls2Ptr->mixins.num != 0) {
+ ckfree(clsPtr->mixins.list);
+ }
+ DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+ }
+
+ /*
+ * Duplicate the source class's methods, constructor and destructor.
+ */
+
+ FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
+ if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr,
+ NULL) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (clsPtr->constructorPtr) {
+ if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr,
+ NULL, &cls2Ptr->constructorPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (clsPtr->destructorPtr) {
+ if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL,
+ &cls2Ptr->destructorPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+
+ /*
+ * Duplicate the class's metadata.
+ */
+
+ if (clsPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ duplicate = value;
+ } else {
+ if (metadataTypePtr->cloneProc(interp, value,
+ &duplicate) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (duplicate != NULL) {
+ Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+ }
+
+ return (Tcl_Object) o2Ptr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CloneObjectMethod, CloneClassMethod --
+ *
+ * Helper functions used for cloning methods. They work identically to
+ * each other, except for the difference between them in how they
+ * register the cloned method on a successful clone.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+CloneObjectMethod(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr)
+{
+ if (mPtr->typePtr == NULL) {
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
+ } else {
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
+ }
+ return TCL_OK;
+}
+
+static int
+CloneClassMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr,
+ Method **m2PtrPtr)
+{
+ Method *m2Ptr;
+
+ if (mPtr->typePtr == NULL) {
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ newClientData);
+ } else {
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ mPtr->clientData);
+ }
+ if (m2PtrPtr != NULL) {
+ *m2PtrPtr = m2Ptr;
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
+ * Tcl_ObjectSetMetadata --
+ *
+ * Metadata management API. The metadata system allows code in extensions
+ * to attach arbitrary non-NULL pointers to objects and classes without
+ * the different things that might be interested being able to interfere
+ * with each other. Apart from non-NULL-ness, these routines attach no
+ * interpretation to the meaning of the metadata pointers.
+ *
+ * The Tcl_*GetMetadata routines get the metadata pointer attached that
+ * has been related with a particular type, or NULL if no metadata
+ * associated with the given type has been attached.
+ *
+ * The Tcl_*SetMetadata routines set or delete the metadata pointer that
+ * is related to a particular type. The value associated with the type is
+ * deleted (if present; no-op otherwise) if the value is NULL, and
+ * attached (replacing the previous value, which is deleted if present)
+ * otherwise. This means it is impossible to attach a NULL value for any
+ * metadata type.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_ClassGetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ }
+ return Tcl_GetHashValue(hPtr);
+}
+
+void
+Tcl_ClassSetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+ClientData
+Tcl_ObjectGetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ }
+ return Tcl_GetHashValue(hPtr);
+}
+
+void
+Tcl_ObjectSetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ *
+ * Main entry point for object invokations. The Public* and Private*
+ * wrapper functions (implementations of both object instance commands
+ * and [my]) are just thin wrappers round the main TclOOObjectCmdCore
+ * function. Note that the core is function is NRE-aware.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PublicObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
+}
+
+static int
+PublicNRObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
+ NULL);
+}
+
+static int
+PrivateObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
+}
+
+static int
+PrivateNRObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
+}
+
+int
+TclOOInvokeObject(
+ Tcl_Interp *interp, /* Interpreter for commands, variables,
+ * results, error reporting, etc. */
+ Tcl_Object object, /* The object to invoke. */
+ Tcl_Class startCls, /* Where in the class chain to start the
+ * invoke from, or NULL to traverse the whole
+ * chain including filters. */
+ int publicPrivate, /* Whether this is an invoke from a public
+ * context (PUBLIC_METHOD), a private context
+ * (PRIVATE_METHOD), or a *really* private
+ * context (any other value; conventionally
+ * 0). */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
+ * that the name of the method to invoke will
+ * be at index 1. */
+{
+ switch (publicPrivate) {
+ case PUBLIC_METHOD:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
+ PUBLIC_METHOD, (Class *) startCls);
+ case PRIVATE_METHOD:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
+ PRIVATE_METHOD, (Class *) startCls);
+ default:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
+ (Class *) startCls);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectCmdCore, FinalizeObjectCall --
+ *
+ * Main function for object invokations. Does call chain creation,
+ * management and invokation. The function FinalizeObjectCall exists to
+ * clean up after the non-recursive processing of TclOOObjectCmdCore.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOObjectCmdCore(
+ Object *oPtr, /* The object being invoked. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ int objc, /* How many arguments are being passed in. */
+ Tcl_Obj *const *objv, /* The array of arguments. */
+ int flags, /* Whether this is an invokation through the
+ * public or the private command interface. */
+ Class *startCls) /* Where to start in the call chain, or NULL
+ * if we are to start at the front with
+ * filters and the object's methods (which is
+ * the normal case). */
+{
+ CallContext *contextPtr;
+ Tcl_Obj *methodNamePtr;
+ int result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Give plugged in code a chance to remap the method name.
+ */
+
+ methodNamePtr = objv[1];
+ if (oPtr->mapMethodNameProc != NULL) {
+ register Class **startClsPtr = &startCls;
+ Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
+
+ result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
+ (Tcl_Class *) startClsPtr, mappedMethodName);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(mappedMethodName);
+ if (result == TCL_BREAK) {
+ goto noMapping;
+ } else if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (while mapping method name)");
+ }
+ return result;
+ }
+
+ /*
+ * Get the call chain for the remapped name.
+ */
+
+ Tcl_IncrRefCount(mappedMethodName);
+ contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
+ flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+ Tcl_DecrRefCount(mappedMethodName);
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(methodNamePtr),
+ "\": no defined method or unknown method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
+ TclGetString(methodNamePtr), NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Get the call chain.
+ */
+
+ noMapping:
+ contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
+ flags | (oPtr->flags & FILTER_HANDLING), NULL);
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(methodNamePtr),
+ "\": no defined method or unknown method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(methodNamePtr), NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Check to see if we need to apply magical tricks to start part way
+ * through the call chain.
+ */
+
+ if (startCls != NULL) {
+ for (; contextPtr->index < contextPtr->callPtr->numChain;
+ contextPtr->index++) {
+ register struct MInvoke *miPtr =
+ &contextPtr->callPtr->chain[contextPtr->index];
+
+ if (miPtr->isFilter) {
+ continue;
+ }
+ if (miPtr->mPtr->declaringClassPtr == startCls) {
+ break;
+ }
+ }
+ if (contextPtr->index >= contextPtr->callPtr->numChain) {
+ Tcl_SetResult(interp, "no valid method implementation",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(methodNamePtr), NULL);
+ TclOODeleteContext(contextPtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Invoke the call chain, locking the object structure against deletion
+ * for the duration.
+ */
+
+ TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeObjectCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ /*
+ * Dispose of the call chain, which drops the lock on the object's
+ * structure.
+ */
+
+ TclOODeleteContext(data[0]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
+ *
+ * Invokes the next stage of the call chain described in an object
+ * context. This is the core of the implementation of the [next] command.
+ * Does not do management of the call-frame stack. Available in public
+ * (standard API) and private (NRE-aware) forms. FinalizeNext is a
+ * private function used to clean up in the NRE case.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+Tcl_ObjectContextInvokeNext(
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv,
+ int skip)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ int savedIndex = contextPtr->index;
+ int savedSkip = contextPtr->skip;
+ int result;
+
+ if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless the
+ * interpreter is being torn down, in which case we might be getting
+ * here because of methods/destructors doing a [next] (or equivalent)
+ * unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (Tcl_InterpDeleted(interp)) {
+ return TCL_OK;
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ Tcl_AppendResult(interp, "no next ", methodType, " implementation",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance to the next method implementation in the chain in the method
+ * call context while we process the body. However, need to adjust the
+ * argument-skip control because we're guaranteed to have a single prefix
+ * arg (i.e., 'next') and not the variable amount that can happen because
+ * method invokations (i.e., '$obj meth' and 'my meth'), constructors
+ * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
+ * all) come through the same code.
+ */
+
+ contextPtr->index++;
+ contextPtr->skip = skip;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context.
+ */
+
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc,
+ objv);
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = savedIndex;
+ contextPtr->skip = savedSkip;
+
+ return result;
+}
+
+int
+TclNRObjectContextInvokeNext(
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv,
+ int skip)
+{
+ register CallContext *contextPtr = (CallContext *) context;
+
+ if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless the
+ * interpreter is being torn down, in which case we might be getting
+ * here because of methods/destructors doing a [next] (or equivalent)
+ * unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (Tcl_InterpDeleted(interp)) {
+ return TCL_OK;
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ Tcl_AppendResult(interp, "no next ", methodType, " implementation",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance to the next method implementation in the chain in the method
+ * call context while we process the body. However, need to adjust the
+ * argument-skip control because we're guaranteed to have a single prefix
+ * arg (i.e., 'next') and not the variable amount that can happen because
+ * method invokations (i.e., '$obj meth' and 'my meth'), constructors
+ * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
+ * all) come through the same code.
+ */
+
+ TclNRAddCallback(interp, FinalizeNext, contextPtr,
+ INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
+ contextPtr->index++;
+ contextPtr->skip = skip;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context.
+ */
+
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeNext(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[1]);
+ contextPtr->skip = PTR2INT(data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_GetObjectFromObj --
+ *
+ * Utility function to get an object from a Tcl_Obj containing its name.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_GetObjectFromObj(
+ Tcl_Interp *interp, /* Interpreter in which to locate the object.
+ * Will have an error message placed in it if
+ * the name does not refer to an object. */
+ Tcl_Obj *objPtr) /* The name of the object to look up, which is
+ * exactly the name of its public command. */
+{
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if (cmdPtr == NULL) {
+ goto notAnObject;
+ }
+ if (cmdPtr->objProc != PublicObjectCmd) {
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ goto notAnObject;
+ }
+ }
+ return cmdPtr->objClientData;
+
+ notAnObject:
+ Tcl_AppendResult(interp, TclGetString(objPtr),
+ " does not refer to an object", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
+ NULL);
+ return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOIsReachable --
+ *
+ * Utility function that tests whether a class is a subclass (whether
+ * directly or indirectly) of another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOIsReachable(
+ Class *targetPtr,
+ Class *startPtr)
+{
+ int i;
+ Class *superPtr;
+
+ tailRecurse:
+ if (startPtr == targetPtr) {
+ return 1;
+ }
+ if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
+ startPtr = startPtr->superclasses.list[0];
+ goto tailRecurse;
+ }
+ FOREACH(superPtr, startPtr->superclasses) {
+ if (TclOOIsReachable(targetPtr, superPtr)) {
+ return 1;
+ }
+ }
+ FOREACH(superPtr, startPtr->mixins) {
+ if (TclOOIsReachable(targetPtr, superPtr)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectName, Tcl_GetObjectName --
+ *
+ * Utility function that returns the name of the object. Note that this
+ * simplifies cache management by keeping the code to do it in one place
+ * and not sprayed all over. The value returned always has a reference
+ * count of at least one.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOObjectName(
+ Tcl_Interp *interp,
+ Object *oPtr)
+{
+ Tcl_Obj *namePtr;
+
+ if (oPtr->cachedNameObj) {
+ return oPtr->cachedNameObj;
+ }
+ namePtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
+ Tcl_IncrRefCount(namePtr);
+ oPtr->cachedNameObj = namePtr;
+ return namePtr;
+}
+
+Tcl_Obj *
+Tcl_GetObjectName(
+ Tcl_Interp *interp,
+ Tcl_Object object)
+{
+ return TclOOObjectName(interp, (Object *) object);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * assorted trivial 'getter' functions
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_ObjectContextMethod(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr;
+}
+
+int
+Tcl_ObjectContextIsFiltering(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return contextPtr->callPtr->chain[contextPtr->index].isFilter;
+}
+
+Tcl_Object
+Tcl_ObjectContextObject(
+ Tcl_ObjectContext context)
+{
+ return (Tcl_Object) ((CallContext *)context)->oPtr;
+}
+
+int
+Tcl_ObjectContextSkippedArgs(
+ Tcl_ObjectContext context)
+{
+ return ((CallContext *)context)->skip;
+}
+
+Tcl_Namespace *
+Tcl_GetObjectNamespace(
+ Tcl_Object object)
+{
+ return ((Object *)object)->namespacePtr;
+}
+
+Tcl_Command
+Tcl_GetObjectCommand(
+ Tcl_Object object)
+{
+ return ((Object *)object)->command;
+}
+
+Tcl_Class
+Tcl_GetObjectAsClass(
+ Tcl_Object object)
+{
+ return (Tcl_Class) ((Object *)object)->classPtr;
+}
+
+int
+Tcl_ObjectDeleted(
+ Tcl_Object object)
+{
+ return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+}
+
+Tcl_Object
+Tcl_GetClassAsObject(
+ Tcl_Class clazz)
+{
+ return (Tcl_Object) ((Class *)clazz)->thisPtr;
+}
+
+Tcl_ObjectMapMethodNameProc *
+Tcl_ObjectGetMethodNameMapper(
+ Tcl_Object object)
+{
+ return ((Object *) object)->mapMethodNameProc;
+}
+
+void
+Tcl_ObjectSetMethodNameMapper(
+ Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc *mapMethodNameProc)
+{
+ ((Object *) object)->mapMethodNameProc = mapMethodNameProc;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
new file mode 100644
index 0000000..027dcd0
--- /dev/null
+++ b/generic/tclOO.decls
@@ -0,0 +1,204 @@
+library tclOO
+
+######################################################################
+# public API
+#
+
+interface tclOO
+hooks tclOOInt
+scspec EXTERN
+
+declare 0 {
+ Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
+ Tcl_Object sourceObject, const char *targetName,
+ const char *targetNamespaceName)
+}
+declare 1 {
+ Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz)
+}
+declare 2 {
+ Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object)
+}
+declare 3 {
+ Tcl_Command Tcl_GetObjectCommand(Tcl_Object object)
+}
+declare 4 {
+ Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+}
+declare 5 {
+ Tcl_Namespace *Tcl_GetObjectNamespace(Tcl_Object object)
+}
+declare 6 {
+ Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method)
+}
+declare 7 {
+ Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
+}
+declare 8 {
+ int Tcl_MethodIsPublic(Tcl_Method method)
+}
+declare 9 {
+ int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr)
+}
+declare 10 {
+ Tcl_Obj *Tcl_MethodName(Tcl_Method method)
+}
+declare 11 {
+ Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ ClientData clientData)
+}
+declare 12 {
+ Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ ClientData clientData)
+}
+declare 13 {
+ Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
+ const char *nameStr, const char *nsNameStr, int objc,
+ Tcl_Obj *const *objv, int skip)
+}
+declare 14 {
+ int Tcl_ObjectDeleted(Tcl_Object object)
+}
+declare 15 {
+ int Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context)
+}
+declare 16 {
+ Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context)
+}
+declare 17 {
+ Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
+}
+declare 18 {
+ int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
+}
+declare 19 {
+ ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr)
+}
+declare 20 {
+ void Tcl_ClassSetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
+}
+declare 21 {
+ ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr)
+}
+declare 22 {
+ void Tcl_ObjectSetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
+}
+declare 23 {
+ int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv,
+ int skip)
+}
+declare 24 {
+ Tcl_ObjectMapMethodNameProc *Tcl_ObjectGetMethodNameMapper(
+ Tcl_Object object)
+}
+declare 25 {
+ void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc *mapMethodNameProc)
+}
+declare 26 {
+ void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz,
+ Tcl_Method method)
+}
+declare 27 {
+ void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz,
+ Tcl_Method method)
+}
+declare 28 {
+ Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
+}
+
+######################################################################
+# private API, exposed to support advanced OO systems that plug in on top
+#
+
+interface tclOOInt
+
+declare 0 {
+ Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp)
+}
+declare 1 {
+ 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)
+}
+declare 2 {
+ 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)
+}
+declare 3 {
+ Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
+ int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr)
+}
+declare 4 {
+ Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+ int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr)
+}
+declare 5 {
+ int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int publicOnly, Class *startCls)
+}
+declare 6 {
+ int TclOOIsReachable(Class *targetPtr, Class *startPtr)
+}
+declare 7 {
+ Method *TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr,
+ int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
+}
+declare 8 {
+ Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
+ int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
+}
+declare 9 {
+ Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+ Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr,
+ TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc,
+ ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
+ Tcl_Obj *bodyObj, int flags, void **internalTokenPtr)
+}
+declare 10 {
+ Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr,
+ TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
+ ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags,
+ void **internalTokenPtr)
+}
+declare 11 {
+ int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Class startCls, int publicPrivate, int objc,
+ Tcl_Obj *const *objv)
+}
+declare 12 {
+ void TclOOObjectSetFilters(Object *oPtr, int numFilters,
+ Tcl_Obj *const *filters)
+}
+declare 13 {
+ void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr,
+ int numFilters, Tcl_Obj *const *filters)
+}
+declare 14 {
+ void TclOOObjectSetMixins(Object *oPtr, int numMixins,
+ Class *const *mixins)
+}
+declare 15 {
+ void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
+ int numMixins, Class *const *mixins)
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/generic/tclOO.h b/generic/tclOO.h
new file mode 100644
index 0000000..ed70c08
--- /dev/null
+++ b/generic/tclOO.h
@@ -0,0 +1,126 @@
+/*
+ * tclOO.h --
+ *
+ * This file contains the public API definitions and some of the function
+ * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006-2008 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.
+ */
+
+#ifndef TCLOO_H_INCLUDED
+#define TCLOO_H_INCLUDED
+#include "tcl.h"
+
+/*
+ * Be careful when it comes to versioning; need to make sure that the
+ * standalone TclOO version matches. Also make sure that this matches the
+ * version in the files:
+ *
+ * tests/oo.test
+ * unix/tclooConfig.sh
+ * win/tclooConfig.sh
+ */
+
+#define TCLOO_VERSION "0.6.2"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION
+
+/*
+ * These are opaque types.
+ */
+
+typedef struct Tcl_Class_ *Tcl_Class;
+typedef struct Tcl_Method_ *Tcl_Method;
+typedef struct Tcl_Object_ *Tcl_Object;
+typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
+
+/*
+ * Public datatypes for callbacks and structures used in the TIP#257 (OO)
+ * implementation. These are used to implement custom types of method calls
+ * and to allow the attachment of arbitrary data to objects and classes.
+ */
+
+typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef void (Tcl_MethodDeleteProc)(ClientData clientData);
+typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData,
+ ClientData *newClientData);
+typedef void (Tcl_ObjectMetadataDeleteProc)(ClientData clientData);
+typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);
+
+/*
+ * The type of a method implementation. This describes how to call the method
+ * implementation, how to delete it (when the object or class is deleted) and
+ * how to create a clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_CURRENT in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc *callProc;
+ /* How to invoke this method. */
+ Tcl_MethodDeleteProc *deleteProc;
+ /* How to delete this method's type-specific
+ * data, or NULL if the type-specific data
+ * does not need deleting. */
+ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType;
+
+/*
+ * The correct value for the version field of the Tcl_MethodType structure.
+ * This allows new versions of the structure to be introduced without breaking
+ * binary compatability.
+ */
+
+#define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * The type of some object (or class) metadata. This describes how to delete
+ * the metadata (when the object or class is deleted) and how to create a
+ * clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METADATA_VERSION_CURRENT in
+ * declarations. */
+ const char *name;
+ Tcl_ObjectMetadataDeleteProc *deleteProc;
+ /* How to delete the metadata. This must not
+ * be NULL. */
+ Tcl_CloneProc *cloneProc; /* How to copy the metadata, or NULL if the
+ * type-specific data can be copied
+ * directly. */
+} Tcl_ObjectMetadataType;
+
+/*
+ * The correct value for the version field of the Tcl_ObjectMetadataType
+ * structure. This allows new versions of the structure to be introduced
+ * without breaking binary compatability.
+ */
+
+#define TCL_OO_METADATA_VERSION_CURRENT 1
+
+/*
+ * Include all the public API, generated from tclOO.decls.
+ */
+
+#include "tclOODecls.h"
+
+#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
new file mode 100644
index 0000000..0d38dcd
--- /dev/null
+++ b/generic/tclOOBasic.c
@@ -0,0 +1,1112 @@
+/*
+ * tclOOBasic.c --
+ *
+ * This file contains implementations of the "simple" commands and
+ * methods from the object-system core.
+ *
+ * Copyright (c) 2005-2011 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
+static int AfterNRDestructor(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeConstruction(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeEval(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int RestoreFrame(ClientData data[],
+ Tcl_Interp *interp, int result);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddCreateCallback, FinalizeConstruction --
+ *
+ * Special version of TclNRAddCallback that allows the caller to splice
+ * the object created later on. Always calls FinalizeConstruction, which
+ * converts the object into its name and stores that in the interpreter
+ * result. This is shared by all the construction methods (create,
+ * createWithNamespace, new).
+ *
+ * Note that this is the only code in this file (or, indeed, the whole of
+ * TclOO) that uses NRE internals; it is the only code that does
+ * non-standard poking in the NRE guts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Tcl_Object *
+AddConstructionFinalizer(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
+ return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
+}
+
+static int
+FinalizeConstruction(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Object *oPtr = data[0];
+
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_Create --
+ *
+ * Implementation for oo::class->create method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Create(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ const char *objName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, NULL, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+1,
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_CreateNs --
+ *
+ * Implementation for oo::class->createWithNamespace method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_CreateNs(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ const char *objName, *nsName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName namespaceName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+ nsName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, nsName, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+2,
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_New --
+ *
+ * Implementation for oo::class->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_New(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Destroy --
+ *
+ * Implementation for oo::object->destroy method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Destroy(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ CallContext *contextPtr;
+
+ if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
+ oPtr->flags |= DESTRUCTOR_CALLED;
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ if (contextPtr != NULL) {
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
+ NULL, NULL, NULL);
+ return TclOOInvokeContext(contextPtr, interp, 0, NULL);
+ }
+ }
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ return TCL_OK;
+}
+
+static int
+AfterNRDestructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ if (contextPtr->oPtr->command) {
+ Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
+ }
+ TclOODeleteContext(contextPtr);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Eval --
+ *
+ * Implementation for oo::object->eval method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Eval(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ register const int skip = Tcl_ObjectContextSkippedArgs(context);
+ CallFrame *framePtr, **framePtrPtr = &framePtr;
+ Tcl_Obj *scriptPtr;
+ int result;
+ CmdFrame *invoker;
+
+ if (objc-1 < skip) {
+ Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object's namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ Tcl_GetObjectNamespace(object), 0);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+
+ if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) {
+ object = NULL; /* Now just for error mesage printing. */
+ }
+
+ /*
+ * Work out what script we are actually going to evaluate.
+ *
+ * When there's more than one argument, we concatenate them together with
+ * spaces between, then evaluate the result. Tcl_EvalObjEx will delete the
+ * object when it decrements its refcount after eval'ing it.
+ */
+
+ if (objc != skip+1) {
+ scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
+ invoker = NULL;
+ } else {
+ scriptPtr = objv[skip];
+ invoker = ((Interp *) interp)->cmdFramePtr;
+ }
+
+ /*
+ * Evaluate the script now, with FinalizeEval to do the processing after
+ * the script completes.
+ */
+
+ TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip);
+}
+
+static int
+FinalizeEval(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ if (result == TCL_ERROR) {
+ Object *oPtr = data[0];
+ const char *namePtr;
+
+ if (oPtr) {
+ namePtr = TclGetString(TclOOObjectName(interp, oPtr));
+ } else {
+ namePtr = "my";
+ }
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in \"%s eval\" script line %d)",
+ namePtr, Tcl_GetErrorLine(interp)));
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Unknown --
+ *
+ * Default unknown method handler method (defined in oo::object). This
+ * just creates a suitable error message.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Unknown(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Object *oPtr = contextPtr->oPtr;
+ const char **methodNames;
+ int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+
+ if (objc < skip+1) {
+ Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the list of methods that we want to know about.
+ */
+
+ numMethodNames = TclOOGetSortedMethodList(oPtr,
+ contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
+
+ /*
+ * Special message when there are no visible methods at all.
+ */
+
+ if (numMethodNames == 0) {
+ Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
+ if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
+ Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ } else {
+ Tcl_AppendResult(interp, "\" has no methods", NULL);
+ }
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[skip]), NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
+ "\": must be ", NULL);
+ for (i=0 ; i<numMethodNames-1 ; i++) {
+ if (i) {
+ Tcl_AppendResult(interp, ", ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ }
+ if (i) {
+ Tcl_AppendResult(interp, " or ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ ckfree(methodNames);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[skip]), NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_LinkVar --
+ *
+ * Implementation of oo::object->variable method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_LinkVar(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ Namespace *savedNsPtr;
+ int i;
+
+ if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?varName ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * A sanity check. Shouldn't ever happen. (This is all that remains of a
+ * more complex check inherited from [global] after we have applied the
+ * fix for [Bug 2903811]; note that the fix involved *removing* code.)
+ */
+
+ if (iPtr->varFramePtr == NULL) {
+ return TCL_OK;
+ }
+
+ for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
+ Var *varPtr, *aryPtr;
+ const char *varName = TclGetString(objv[i]);
+
+ /*
+ * The variable name must not contain a '::' since that's illegal in
+ * local names.
+ */
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "variable name \"", varName,
+ "\" illegal: must not contain namespace separator", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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).
+ */
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(object);
+ varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
+ "define", 1, 0, &aryPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+
+ if (varPtr == NULL || aryPtr != NULL) {
+ /*
+ * Variable cannot be an element in an array. If aryPtr is not
+ * NULL, it is an element, so throw up an error and return.
+ */
+
+ TclVarErrMsg(interp, varName, NULL, "define",
+ "name refers to an element in an array");
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Arrange for the lifetime of the variable to be correctly managed.
+ * This is copied out of Tcl_VariableObjCmd...
+ */
+
+ if (!TclIsVarNamespaceVar(varPtr)) {
+ TclSetVarNamespaceVar(varPtr);
+ }
+
+ if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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).
+ */
+
+ 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);
+ } else {
+ Namespace *savedNsPtr;
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ 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;
+ }
+
+ if (varPtr == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
+ TclGetString(objv[objc-1]), NULL);
+ return TCL_ERROR;
+ }
+
+ varNamePtr = Tcl_NewObj();
+ if (aryVar != NULL) {
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
+
+ /*
+ * WARNING! This code pokes inside the implementation of hash tables!
+ */
+
+ hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
+ &search);
+ while (hPtr != NULL) {
+ if (varPtr == Tcl_GetHashValue(hPtr)) {
+ Tcl_AppendToObj(varNamePtr, "(", -1);
+ Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
+ Tcl_AppendToObj(varNamePtr, ")", -1);
+ break;
+ }
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ } else {
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ }
+ Tcl_SetObjResult(interp, varNamePtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONextObjCmd --
+ *
+ * Implementation of the [next] command. Note that this command is only
+ * ever to be used inside the body of a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOONextObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ Tcl_ObjectContext context;
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+ context = framePtr->clientData;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context. Note
+ * that this is like [uplevel 1] and not [eval].
+ */
+
+ TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
+}
+
+static int
+RestoreFrame(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ iPtr->varFramePtr = data[0];
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOSelfObjCmd --
+ *
+ * Implementation of the [self] command, which provides introspection of
+ * the call context.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *const subcmds[] = {
+ "caller", "class", "filter", "method", "namespace", "next", "object",
+ "target", NULL
+ };
+ enum SelfCmds {
+ SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
+ SELF_OBJECT, SELF_TARGET
+ };
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ int index;
+
+#define CurrentlyInvoked(contextPtr) \
+ ((contextPtr)->callPtr->chain[(contextPtr)->index])
+
+ /*
+ * Start with sanity checks on the calling context and the method context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Now we do "conventional" argument parsing for a while. Note that no
+ * subcommand takes arguments.
+ */
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
+ return TCL_ERROR;
+ } else if (objc == 1) {
+ index = SELF_OBJECT;
+ } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum SelfCmds) index) {
+ case SELF_OBJECT:
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
+ return TCL_OK;
+ case SELF_NS:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ contextPtr->oPtr->namespacePtr->fullName,-1));
+ return TCL_OK;
+ case SELF_CLASS: {
+ Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
+
+ if (clsPtr == NULL) {
+ Tcl_AppendResult(interp, "method not defined by a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
+ return TCL_OK;
+ }
+ case SELF_METHOD:
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
+ } else {
+ Tcl_SetObjResult(interp,
+ CurrentlyInvoked(contextPtr).mPtr->namePtr);
+ }
+ return TCL_OK;
+ case SELF_FILTER:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ } else {
+ register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ Tcl_Obj *result[3];
+ Object *oPtr;
+ const char *type;
+
+ if (miPtr->filterDeclarer != NULL) {
+ oPtr = miPtr->filterDeclarer->thisPtr;
+ type = "class";
+ } else {
+ oPtr = contextPtr->oPtr;
+ type = "object";
+ }
+
+ result[0] = TclOOObjectName(interp, oPtr);
+ result[1] = Tcl_NewStringObj(type, -1);
+ result[2] = miPtr->mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+ }
+ case SELF_CALLER:
+ if ((framePtr->callerVarPtr == NULL) ||
+ !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
+ Tcl_AppendResult(interp, "caller is not an object", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ } else {
+ CallContext *callerPtr = framePtr->callerVarPtr->clientData;
+ Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *result[3];
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = TclOOObjectName(interp, callerPtr->oPtr);
+ if (callerPtr->callPtr->flags & CONSTRUCTOR) {
+ result[2] = declarerPtr->fPtr->constructorName;
+ } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
+ result[2] = declarerPtr->fPtr->destructorName;
+ } else {
+ result[2] = mPtr->namePtr;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+ }
+ case SELF_NEXT:
+ if (contextPtr->index < contextPtr->callPtr->numChain-1) {
+ Method *mPtr =
+ contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *result[2];
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ result[1] = declarerPtr->fPtr->constructorName;
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ result[1] = declarerPtr->fPtr->destructorName;
+ } else {
+ result[1] = mPtr->namePtr;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+ }
+ return TCL_OK;
+ case SELF_TARGET:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ } else {
+ Method *mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *result[2];
+ int i;
+
+ for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
+ if (!contextPtr->callPtr->chain[i].isFilter) {
+ break;
+ }
+ }
+ if (i == contextPtr->callPtr->numChain) {
+ Tcl_Panic("filtering call chain without terminal non-filter");
+ }
+ mPtr = contextPtr->callPtr->chain[i].mPtr;
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CopyObjectCmd --
+ *
+ * Implementation of the [oo::copy] command, which clones an object (but
+ * not its namespace). Note that no constructors are called during this
+ * process.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOCopyObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object oPtr, o2Ptr;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+ return TCL_ERROR;
+ }
+
+ oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a cloned object of the correct class. Note that constructors are
+ * not called. Also note that we must resolve the object name ourselves
+ * because we do not want to create the object in the current namespace,
+ * but rather in the context of the namespace of the caller of the overall
+ * [oo::define] command.
+ */
+
+ if (objc == 2) {
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
+ } else {
+ const char *name;
+ Tcl_DString buffer;
+
+ name = TclGetString(objv[2]);
+ Tcl_DStringInit(&buffer);
+ if (name[0]!=':' || name[1]!=':') {
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->varFramePtr != NULL) {
+ Tcl_DStringAppend(&buffer,
+ iPtr->varFramePtr->nsPtr->fullName, -1);
+ }
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, name, -1);
+ name = Tcl_DStringValue(&buffer);
+ }
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the name of the cloned object.
+ */
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOUpcatchCmd --
+ *
+ * Implementation of the [oo::UpCatch] command, which is a combination of
+ * [uplevel 1] and [catch] that makes it easier to write transparent
+ * error handling in scripts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOUpcatchCmd(
+ ClientData ignored,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
+}
+
+static int
+UpcatchCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *savedFramePtr = data[0];
+ Tcl_Obj *resultObj[2];
+ int rewind = iPtr->execEnvPtr->rewind;
+
+ iPtr->varFramePtr = savedFramePtr;
+ if (rewind || Tcl_LimitExceeded(interp)) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
+ return TCL_ERROR;
+ }
+ resultObj[0] = Tcl_GetObjResult(interp);
+ resultObj[1] = Tcl_GetReturnOptions(interp, result);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
+ return TCL_OK;
+}
+
+int
+TclOONRUpcatch(
+ ClientData ignored,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script");
+ return TCL_ERROR;
+ }
+ if (iPtr->varFramePtr->callerVarPtr != NULL) {
+ iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+ }
+
+ Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
+ return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
+ iPtr->cmdFramePtr, 1);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
new file mode 100644
index 0000000..1e8d1a3
--- /dev/null
+++ b/generic/tclOOCall.c
@@ -0,0 +1,1264 @@
+/*
+ * tclOOCall.c --
+ *
+ * This file contains the method call chain management code for the
+ * object-system core.
+ *
+ * Copyright (c) 2005-2011 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Structure containing a CallContext and any other values needed only during
+ * the construction of the CallContext.
+ */
+
+struct ChainBuilder {
+ CallChain *callChainPtr; /* The call chain being built. */
+ int filterLength; /* Number of entries in the call chain that
+ * are due to processing filters and not the
+ * main call chain. */
+ Object *oPtr; /* The object that we are building the chain
+ * for. */
+};
+
+/*
+ * Extra flags used for call chain management.
+ */
+
+#define DEFINITE_PROTECTED 0x100000
+#define DEFINITE_PUBLIC 0x200000
+#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
+#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static void AddClassFiltersToCallContext(Object *const oPtr,
+ Class *clsPtr, struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters);
+static void AddClassMethodNames(Class *clsPtr, const int flags,
+ Tcl_HashTable *const namesPtr);
+static inline void AddMethodToCallChain(Method *const mPtr,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters,
+ Class *const filterDecl);
+static inline void AddSimpleChainToCallContext(Object *const oPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static void AddSimpleClassChainToCallContext(Class *classPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static int CmpStr(const void *ptr1, const void *ptr2);
+static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
+static int FinalizeMethodRefs(ClientData data[],
+ Tcl_Interp *interp, int result);
+static void FreeMethodNameRep(Tcl_Obj *objPtr);
+static inline int IsStillValid(CallChain *callPtr, Object *oPtr,
+ int flags, int reuseMask);
+static int ResetFilterFlags(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int SetFilterFlags(ClientData data[],
+ Tcl_Interp *interp, int result);
+static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
+
+/*
+ * Object type used to manage type caches attached to method names.
+ */
+
+static const Tcl_ObjType methodNameType = {
+ "TclOO method name",
+ FreeMethodNameRep,
+ DupMethodNameRep,
+ NULL,
+ NULL
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteContext --
+ *
+ * Destroys a method call-chain context, which should not be in use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteContext(
+ CallContext *contextPtr)
+{
+ register Object *oPtr = contextPtr->oPtr;
+
+ TclOODeleteChain(contextPtr->callPtr);
+ TclStackFree(oPtr->fPtr->interp, contextPtr);
+ DelRef(oPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteChainCache --
+ *
+ * Destroy the cache of method call-chains.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteChainCache(
+ Tcl_HashTable *tablePtr)
+{
+ FOREACH_HASH_DECLS;
+ CallChain *callPtr;
+
+ FOREACH_HASH_VALUE(callPtr, tablePtr) {
+ if (callPtr) {
+ TclOODeleteChain(callPtr);
+ }
+ }
+ Tcl_DeleteHashTable(tablePtr);
+ ckfree(tablePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteChain --
+ *
+ * Destroys a method call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteChain(
+ CallChain *callPtr)
+{
+ if (--callPtr->refCount >= 1) {
+ return;
+ }
+ if (callPtr->chain != callPtr->staticChain) {
+ ckfree(callPtr->chain);
+ }
+ ckfree(callPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOStashContext --
+ *
+ * Saves a reference to a method call context in a Tcl_Obj's internal
+ * representation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+StashCallChain(
+ Tcl_Obj *objPtr,
+ CallChain *callPtr)
+{
+ callPtr->refCount++;
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = &methodNameType;
+ objPtr->internalRep.otherValuePtr = callPtr;
+}
+
+void
+TclOOStashContext(
+ Tcl_Obj *objPtr,
+ CallContext *contextPtr)
+{
+ StashCallChain(objPtr, contextPtr->callPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DupMethodNameRep, FreeMethodNameRep --
+ *
+ * Functions to implement the required parts of the Tcl_Obj guts needed
+ * for caching of method contexts in Tcl_Objs.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DupMethodNameRep(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *dstPtr)
+{
+ register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+
+ dstPtr->typePtr = &methodNameType;
+ dstPtr->internalRep.otherValuePtr = callPtr;
+ callPtr->refCount++;
+}
+
+static void
+FreeMethodNameRep(
+ Tcl_Obj *objPtr)
+{
+ register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+
+ TclOODeleteChain(callPtr);
+ objPtr->internalRep.otherValuePtr = NULL;
+ objPtr->typePtr = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInvokeContext --
+ *
+ * Invokes a single step along a method call-chain context. Note that the
+ * invokation of a step along the chain can cause further steps along the
+ * chain to be invoked. Note that this function is written to be as light
+ * in stack usage as possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInvokeContext(
+ ClientData clientData, /* The method call context. */
+ Tcl_Interp *interp, /* Interpreter for error reporting, and many
+ * other sorts of context handling (e.g.,
+ * commands, variables) depending on method
+ * implementation. */
+ int objc, /* The number of arguments. */
+ Tcl_Obj *const objv[]) /* The arguments as actually seen. */
+{
+ register CallContext *const contextPtr = clientData;
+ Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ const int isFilter =
+ contextPtr->callPtr->chain[contextPtr->index].isFilter;
+
+ /*
+ * If this is the first step along the chain, we preserve the method
+ * entries in the chain so that they do not get deleted out from under our
+ * feet.
+ */
+
+ if (contextPtr->index == 0) {
+ int i;
+
+ for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ AddRef(contextPtr->callPtr->chain[i].mPtr);
+ }
+
+ /*
+ * Ensure that the method name itself is part of the arguments when
+ * we're doing unknown processing.
+ */
+
+ if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
+ contextPtr->skip--;
+ }
+
+ /*
+ * Add a callback to ensure that method references are dropped once
+ * this call is finished.
+ */
+
+ TclNRAddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
+ NULL);
+ }
+
+ /*
+ * Save whether we were in a filter and set up whether we are now.
+ */
+
+ if (contextPtr->oPtr->flags & FILTER_HANDLING) {
+ TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
+ } else {
+ TclNRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
+ }
+ if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ } else {
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ }
+
+ /*
+ * Run the method implementation.
+ */
+
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+}
+
+static int
+SetFilterFlags(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ return result;
+}
+
+static int
+ResetFilterFlags(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ return result;
+}
+
+static int
+FinalizeMethodRefs(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+ int i;
+
+ for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
+ }
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList --
+ *
+ * Discovers the list of method names supported by an object or class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOGetSortedMethodList(
+ Object *oPtr, /* The object to get the method names for. */
+ int flags, /* Whether we just want the public method
+ * names. */
+ const char ***stringsPtr) /* Where to write a pointer to the array of
+ * strings to. */
+{
+ Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
+ * mapping. */
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *mixinPtr;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+ int isWantedIn;
+ void *isWanted;
+
+ Tcl_InitObjHashTable(&names);
+
+ /*
+ * Name the bits used in the names table values.
+ */
+#define IN_LIST 1
+#define NO_IMPLEMENTATION 2
+
+ /*
+ * Process method names due to the object.
+ */
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
+ int isNew;
+
+ if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
+ continue;
+ }
+ hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+ if (isNew) {
+ isWantedIn = ((!(flags & PUBLIC_METHOD)
+ || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
+ isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
+ Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
+ }
+ }
+ }
+
+ /*
+ * Process method names due to private methods on the object's class.
+ */
+
+ if (flags & PRIVATE_METHOD) {
+ FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
+ if (mPtr->flags & PRIVATE_METHOD) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+ if (isNew) {
+ isWantedIn = IN_LIST;
+ if (mPtr->typePtr == NULL) {
+ isWantedIn |= NO_IMPLEMENTATION;
+ }
+ Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
+ } else if (mPtr->typePtr != NULL) {
+ isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
+ if (isWantedIn & NO_IMPLEMENTATION) {
+ isWantedIn &= ~NO_IMPLEMENTATION;
+ Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
+ }
+ }
+ }
+ }
+ }
+
+ /*
+ * Process (normal) method names from the class hierarchy and the mixin
+ * hierarchy.
+ */
+
+ AddClassMethodNames(oPtr->selfCls, flags, &names);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassMethodNames(mixinPtr, flags, &names);
+ }
+
+ /*
+ * See how many (visible) method names there are. If none, we do not (and
+ * should not) try to sort the list of them.
+ */
+
+ i = 0;
+ if (names.numEntries != 0) {
+ const char **strings;
+
+ /*
+ * We need to build the list of methods to sort. We will be using
+ * qsort() for this, because it is very unlikely that the list will be
+ * heavily sorted when it is long enough to matter.
+ */
+
+ strings = ckalloc(sizeof(char *) * names.numEntries);
+ FOREACH_HASH(namePtr, isWanted, &names) {
+ if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
+ if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
+ continue;
+ }
+ strings[i++] = TclGetString(namePtr);
+ }
+ }
+
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names.
+ */
+
+ if (i > 0) {
+ if (i > 1) {
+ qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
+ }
+ *stringsPtr = strings;
+ } else {
+ ckfree(strings);
+ }
+ }
+
+ Tcl_DeleteHashTable(&names);
+ return i;
+}
+
+int
+TclOOGetSortedClassMethodList(
+ Class *clsPtr, /* The class to get the method names for. */
+ int flags, /* Whether we just want the public method
+ * names. */
+ const char ***stringsPtr) /* Where to write a pointer to the array of
+ * strings to. */
+{
+ Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
+ * mapping. */
+ FOREACH_HASH_DECLS;
+ int i;
+ Tcl_Obj *namePtr;
+ void *isWanted;
+
+ Tcl_InitObjHashTable(&names);
+
+ /*
+ * Process method names from the class hierarchy and the mixin hierarchy.
+ */
+
+ AddClassMethodNames(clsPtr, flags, &names);
+
+ /*
+ * See how many (visible) method names there are. If none, we do not (and
+ * should not) try to sort the list of them.
+ */
+
+ i = 0;
+ if (names.numEntries != 0) {
+ const char **strings;
+
+ /*
+ * We need to build the list of methods to sort. We will be using
+ * qsort() for this, because it is very unlikely that the list will be
+ * heavily sorted when it is long enough to matter.
+ */
+
+ strings = ckalloc(sizeof(char *) * names.numEntries);
+ FOREACH_HASH(namePtr, isWanted, &names) {
+ if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
+ if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
+ continue;
+ }
+ strings[i++] = TclGetString(namePtr);
+ }
+ }
+
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names.
+ */
+
+ if (i > 0) {
+ if (i > 1) {
+ qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
+ }
+ *stringsPtr = strings;
+ } else {
+ ckfree(strings);
+ }
+ }
+
+ Tcl_DeleteHashTable(&names);
+ return i;
+}
+
+/* Comparator for GetSortedMethodList */
+static int
+CmpStr(
+ const void *ptr1,
+ const void *ptr2)
+{
+ const char **strPtr1 = (const char **) ptr1;
+ const char **strPtr2 = (const char **) ptr2;
+
+ return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassMethodNames --
+ *
+ * Adds the method names defined by a class (or its superclasses) to the
+ * collection being built. The collection is built in a hash table to
+ * ensure that duplicates are excluded. Helper for GetSortedMethodList().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassMethodNames(
+ Class *clsPtr, /* Class to get method names from. */
+ const int flags, /* Whether we are interested in just the
+ * public method names. */
+ Tcl_HashTable *const namesPtr)
+ /* Reference to the hash table to put the
+ * information in. The hash table maps the
+ * Tcl_Obj * method name to an integral value
+ * describing whether the method is wanted.
+ * This ensures that public/private override
+ * semantics are handled correctly.*/
+{
+ /*
+ * Scope all declarations so that the compiler can stand a good chance of
+ * making the recursive step highly efficient. We also hand-implement the
+ * tail-recursive case using a while loop; C compilers typically cannot do
+ * tail-recursion optimization usefully.
+ */
+
+ if (clsPtr->mixins.num != 0) {
+ Class *mixinPtr;
+ int i;
+
+ /* TODO: Beware of infinite loops! */
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ AddClassMethodNames(mixinPtr, flags, namesPtr);
+ }
+ }
+
+ while (1) {
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+ if (isNew) {
+ int isWanted = (!(flags & PUBLIC_METHOD)
+ || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
+
+ Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
+ } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
+ && mPtr->typePtr != NULL) {
+ int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
+
+ isWanted &= ~NO_IMPLEMENTATION;
+ Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
+ }
+ }
+
+ if (clsPtr->superclasses.num != 1) {
+ break;
+ }
+ clsPtr = clsPtr->superclasses.list[0];
+ }
+ if (clsPtr->superclasses.num != 0) {
+ Class *superPtr;
+ int i;
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassMethodNames(superPtr, flags, namesPtr);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleChainToCallContext --
+ *
+ * The core of the call-chain construction engine, this handles calling a
+ * particular method on a particular object. Note that filters and
+ * unknown handling are already handled by the logic that uses this
+ * function.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddSimpleChainToCallContext(
+ Object *const oPtr, /* Object to add call chain entries for. */
+ Tcl_Obj *const methodNameObj,
+ /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what call chain entries
+ * have been processed. */
+ int flags, /* What sort of call chain are we building. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ int i;
+
+ if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (flags & PUBLIC_METHOD) {
+ if (!(mPtr->flags & PUBLIC_METHOD)) {
+ return;
+ } else {
+ flags |= DEFINITE_PUBLIC;
+ }
+ } else {
+ flags |= DEFINITE_PROTECTED;
+ }
+ }
+ }
+ if (!(flags & SPECIAL)) {
+ Tcl_HashEntry *hPtr;
+ Class *mixinPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+ if (oPtr->methodsPtr) {
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
+ if (hPtr != NULL) {
+ AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
+ doneFilters, filterDecl);
+ }
+ }
+ }
+ AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddMethodToCallChain --
+ *
+ * Utility method that manages the adding of a particular method
+ * implementation to a call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddMethodToCallChain(
+ Method *const mPtr, /* Actual method implementation to add to call
+ * chain (or NULL, a no-op). */
+ struct ChainBuilder *const cbPtr,
+ /* The call chain to add the method
+ * implementation to. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what filters have been
+ * processed. If NULL, not processing filters.
+ * Note that this function does not update
+ * this hashtable. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ register CallChain *callPtr = cbPtr->callChainPtr;
+ int i;
+
+ /*
+ * Return if this is just an entry used to record whether this is a public
+ * method. If so, there's nothing real to call and so nothing to add to
+ * the call chain.
+ */
+
+ if (mPtr == NULL || mPtr->typePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Enforce real private method handling here. We will skip adding this
+ * method IF
+ * 1) we are not allowing private methods, AND
+ * 2) this is a private method, AND
+ * 3) this is a class method, AND
+ * 4) this method was not declared by the class of the current object.
+ *
+ * This does mean that only classes really handle private methods. This
+ * should be sufficient for [incr Tcl] support though.
+ */
+
+ if (!(callPtr->flags & PRIVATE_METHOD)
+ && (mPtr->flags & PRIVATE_METHOD)
+ && (mPtr->declaringClassPtr != NULL)
+ && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain. Skip over
+ * any leading filters.
+ */
+
+ for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
+ if (callPtr->chain[i].mPtr == mPtr &&
+ callPtr->chain[i].isFilter == (doneFilters != NULL)) {
+ /*
+ * Call chain semantics states that methods come as *late* in the
+ * call chain as possible. This is done by copying down the
+ * following methods. Note that this does not change the number of
+ * method invokations in the call chain; it just rearranges them.
+ */
+
+ Class *declCls = callPtr->chain[i].filterDeclarer;
+
+ for (; i+1<callPtr->numChain ; i++) {
+ callPtr->chain[i] = callPtr->chain[i+1];
+ }
+ callPtr->chain[i].mPtr = mPtr;
+ callPtr->chain[i].isFilter = (doneFilters != NULL);
+ callPtr->chain[i].filterDeclarer = declCls;
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the method. This is made a bit more complex by the
+ * fact that we are using some "static" space initially, and only start
+ * realloc-ing if the chain gets long.
+ */
+
+ if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
+ callPtr->chain =
+ ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1));
+ memcpy(callPtr->chain, callPtr->staticChain,
+ sizeof(struct MInvoke) * callPtr->numChain);
+ } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
+ callPtr->chain = ckrealloc(callPtr->chain,
+ sizeof(struct MInvoke) * (callPtr->numChain + 1));
+ }
+ callPtr->chain[i].mPtr = mPtr;
+ callPtr->chain[i].isFilter = (doneFilters != NULL);
+ callPtr->chain[i].filterDeclarer = filterDecl;
+ callPtr->numChain++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitCallChain --
+ * Encoding of the policy of how to set up a call chain. Doesn't populate
+ * the chain with the method implementation data.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+InitCallChain(
+ CallChain *callPtr,
+ Object *oPtr,
+ int flags)
+{
+ callPtr->flags = flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ oPtr = oPtr->selfCls->thisPtr;
+ callPtr->flags |= USE_CLASS_CACHE;
+ }
+ callPtr->epoch = oPtr->fPtr->epoch;
+ callPtr->objectCreationEpoch = oPtr->creationEpoch;
+ callPtr->objectEpoch = oPtr->epoch;
+ callPtr->refCount = 1;
+ callPtr->numChain = 0;
+ callPtr->chain = callPtr->staticChain;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsStillValid --
+ * Calculates whether the given call chain can be used for executing a
+ * method for the given object. The condition on a chain from a cached
+ * location being reusable is:
+ * - Refers to the same object (same creation epoch), and
+ * - Still across the same class structure (same global epoch), and
+ * - Still across the same object strucutre (same local epoch), and
+ * - No public/private/filter magic leakage (same flags, modulo the fact
+ * that a public chain will satisfy a non-public call).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsStillValid(
+ CallChain *callPtr,
+ Object *oPtr,
+ int flags,
+ int mask)
+{
+ if ((oPtr->flags & USE_CLASS_CACHE)) {
+ oPtr = oPtr->selfCls->thisPtr;
+ flags |= USE_CLASS_CACHE;
+ }
+ return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)
+ && (callPtr->objectEpoch == oPtr->epoch)
+ && ((callPtr->flags & mask) == (flags & mask)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetCallContext --
+ *
+ * Responsible for constructing the call context, an ordered list of all
+ * method implementations to be called as part of a method invokation.
+ * This method is central to the whole operation of the OO system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+CallContext *
+TclOOGetCallContext(
+ Object *oPtr, /* The object to get the context for. */
+ Tcl_Obj *methodNameObj, /* The name of the method to get the context
+ * for. NULL when getting a constructor or
+ * destructor chain. */
+ int flags, /* What sort of context are we looking for.
+ * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
+ * PRIVATE_METHOD, DESTRUCTOR and
+ * FILTER_HANDLING are useful. */
+ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
+ * to be in the same object as the
+ * methodNameObj. */
+{
+ CallContext *contextPtr;
+ CallChain *callPtr;
+ struct ChainBuilder cb;
+ int i, count, doFilters;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashTable doneFilters;
+
+ if (cacheInThisObj == NULL) {
+ cacheInThisObj = methodNameObj;
+ }
+ if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
+ hPtr = NULL;
+ doFilters = 0;
+
+ /*
+ * Check if we have a cached valid constructor or destructor.
+ */
+
+ if (flags & CONSTRUCTOR) {
+ callPtr = oPtr->selfCls->constructorChainPtr;
+ if ((callPtr != NULL)
+ && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ } else if (flags & DESTRUCTOR) {
+ callPtr = oPtr->selfCls->destructorChainPtr;
+ if ((oPtr->mixins.num == 0) && (callPtr != NULL)
+ && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ }
+ } else {
+ /*
+ * Check if we can get the chain out of the Tcl_Obj method name or out
+ * of the cache. This is made a bit more complex by the fact that
+ * there are multiple different layers of cache (in the Tcl_Obj, in
+ * the object, and in the class).
+ */
+
+ const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+
+ if (cacheInThisObj->typePtr == &methodNameType) {
+ callPtr = cacheInThisObj->internalRep.otherValuePtr;
+ if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ FreeMethodNameRep(cacheInThisObj);
+ }
+
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ if (oPtr->selfCls->classChainCache != NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
+ (char *) methodNameObj);
+ } else {
+ hPtr = NULL;
+ }
+ } else {
+ if (oPtr->chainCache != NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->chainCache,
+ (char *) methodNameObj);
+ } else {
+ hPtr = NULL;
+ }
+ }
+
+ if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
+ callPtr = Tcl_GetHashValue(hPtr);
+ if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ Tcl_SetHashValue(hPtr, NULL);
+ TclOODeleteChain(callPtr);
+ }
+
+ doFilters = 1;
+ }
+
+ callPtr = ckalloc(sizeof(CallChain));
+ InitCallChain(callPtr, oPtr, flags);
+
+ cb.callChainPtr = callPtr;
+ cb.filterLength = 0;
+ cb.oPtr = oPtr;
+
+ /*
+ * Add all defined filters (if any, and if we're going to be processing
+ * them; they're not processed for constructors, destructors or when we're
+ * in the middle of processing a filter).
+ */
+
+ if (doFilters) {
+ Tcl_Obj *filterObj;
+ Class *mixinPtr;
+
+ doFilters = 1;
+ Tcl_InitObjHashTable(&doneFilters);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters);
+ }
+ FOREACH(filterObj, oPtr->filters) {
+ AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
+ NULL);
+ }
+ AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters);
+ Tcl_DeleteHashTable(&doneFilters);
+ }
+ count = cb.filterLength = callPtr->numChain;
+
+ /*
+ * Add the actual method implementations.
+ */
+
+ AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+
+ /*
+ * Check to see if the method has no implementation. If so, we probably
+ * need to add in a call to the unknown method. Otherwise, set up the
+ * cacheing of the method implementation (if relevant).
+ */
+
+ if (count == callPtr->numChain) {
+ /*
+ * Method does not actually exist. If we're dealing with constructors
+ * or destructors, this isn't a problem.
+ */
+
+ if (flags & SPECIAL) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
+ callPtr->flags |= OO_UNKNOWN_METHOD;
+ callPtr->epoch = -1;
+ if (count == callPtr->numChain) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ } else if (doFilters) {
+ if (hPtr == NULL) {
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ if (oPtr->selfCls->classChainCache == NULL) {
+ oPtr->selfCls->classChainCache =
+ ckalloc(sizeof(Tcl_HashTable));
+
+ Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
+ (char *) methodNameObj, &i);
+ } else {
+ if (oPtr->chainCache == NULL) {
+ oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable));
+
+ Tcl_InitObjHashTable(oPtr->chainCache);
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
+ (char *) methodNameObj, &i);
+ }
+ }
+ callPtr->refCount++;
+ Tcl_SetHashValue(hPtr, callPtr);
+ StashCallChain(cacheInThisObj, callPtr);
+ } else if (flags & CONSTRUCTOR) {
+ if (oPtr->selfCls->constructorChainPtr) {
+ TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
+ }
+ oPtr->selfCls->constructorChainPtr = callPtr;
+ callPtr->refCount++;
+ } else if ((flags & DESTRUCTOR) && oPtr->mixins.num == 0) {
+ if (oPtr->selfCls->destructorChainPtr) {
+ TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
+ }
+ oPtr->selfCls->destructorChainPtr = callPtr;
+ callPtr->refCount++;
+ }
+
+ returnContext:
+ contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
+ contextPtr->oPtr = oPtr;
+ AddRef(oPtr);
+ contextPtr->callPtr = callPtr;
+ contextPtr->skip = 2;
+ contextPtr->index = 0;
+ return contextPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassFiltersToCallContext --
+ *
+ * Logic to make extracting all the filters from the class context much
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassFiltersToCallContext(
+ Object *const oPtr, /* Object that the filters operate on. */
+ Class *clsPtr, /* Class to get the filters from. */
+ struct ChainBuilder *const cbPtr,
+ /* Context to fill with call chain entries. */
+ Tcl_HashTable *const doneFilters)
+ /* Where to record what filters have been
+ * processed. Keys are objects, values are
+ * ignored. */
+{
+ int i;
+ Class *superPtr, *mixinPtr;
+ Tcl_Obj *filterObj;
+
+ tailRecurse:
+ if (clsPtr == NULL) {
+ return;
+ }
+
+ /*
+ * Add all the filters defined by classes mixed into the main class
+ * hierarchy.
+ */
+
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters);
+ }
+
+ /*
+ * Add all the class filters from the current class. Note that the filters
+ * are added starting at the object root, as this allows the object to
+ * override how filters work to extend their behaviour.
+ */
+
+ FOREACH(filterObj, clsPtr->filters) {
+ int isNew;
+
+ (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
+ if (isNew) {
+ AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters,
+ 0, clsPtr);
+ }
+ }
+
+ /*
+ * Now process the recursive case. Notice the tail-call optimization.
+ */
+
+ switch (clsPtr->superclasses.num) {
+ case 1:
+ clsPtr = clsPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassChainToCallContext --
+ *
+ * Construct a call-chain from a class hierarchy.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassChainToCallContext(
+ Class *classPtr, /* Class to add the call chain entries for. */
+ Tcl_Obj *const methodNameObj,
+ /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what call chain entries
+ * have been processed. */
+ int flags, /* What sort of call chain are we building. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ int i;
+ Class *superPtr;
+
+ /*
+ * We hard-code the tail-recursive form. It's by far the most common case
+ * *and* it is much more gentle on the stack.
+ *
+ * Note that mixins must be processed before the main class hierarchy.
+ * [Bug 1998221]
+ */
+
+ tailRecurse:
+ FOREACH(superPtr, classPtr->mixins) {
+ AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+
+ if (flags & CONSTRUCTOR) {
+ AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
+ filterDecl);
+
+ } else if (flags & DESTRUCTOR) {
+ AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
+ filterDecl);
+ } else {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (!(flags & KNOWN_STATE)) {
+ if (flags & PUBLIC_METHOD) {
+ if (mPtr->flags & PUBLIC_METHOD) {
+ flags |= DEFINITE_PUBLIC;
+ } else {
+ return;
+ }
+ } else {
+ flags |= DEFINITE_PROTECTED;
+ }
+ }
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl);
+ }
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
new file mode 100644
index 0000000..80a10bb
--- /dev/null
+++ b/generic/tclOODecls.h
@@ -0,0 +1,247 @@
+/*
+ * This file is (mostly) automatically generated from tclOO.decls.
+ */
+
+#ifndef _TCLOODECLS
+#define _TCLOODECLS
+
+#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
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tclOO.decls script.
+ */
+
+#if defined(USE_TCL_STUBS)
+extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version);
+#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION)
+#else
+#define Tcl_OOInitStubs(interp) \
+ Tcl_PkgRequire((interp),"TclOO",TCLOO_VERSION,0)
+#endif
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
+ Tcl_Object sourceObject,
+ const char *targetName,
+ const char *targetNamespaceName);
+/* 1 */
+EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz);
+/* 2 */
+EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object);
+/* 3 */
+EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object);
+/* 4 */
+EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+/* 5 */
+EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
+/* 6 */
+EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method);
+/* 7 */
+EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method);
+/* 8 */
+EXTERN int Tcl_MethodIsPublic(Tcl_Method method);
+/* 9 */
+EXTERN int Tcl_MethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr);
+/* 10 */
+EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method);
+/* 11 */
+EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int isPublic, const Tcl_MethodType *typePtr,
+ ClientData clientData);
+/* 12 */
+EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int isPublic,
+ const Tcl_MethodType *typePtr,
+ ClientData clientData);
+/* 13 */
+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 */
+EXTERN int Tcl_ObjectDeleted(Tcl_Object object);
+/* 15 */
+EXTERN int Tcl_ObjectContextIsFiltering(
+ Tcl_ObjectContext context);
+/* 16 */
+EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+/* 17 */
+EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
+/* 18 */
+EXTERN int Tcl_ObjectContextSkippedArgs(
+ Tcl_ObjectContext context);
+/* 19 */
+EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr);
+/* 20 */
+EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata);
+/* 21 */
+EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr);
+/* 22 */
+EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata);
+/* 23 */
+EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const *objv, int skip);
+/* 24 */
+EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
+ Tcl_Object object);
+/* 25 */
+EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
+/* 26 */
+EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp,
+ Tcl_Class clazz, Tcl_Method method);
+/* 27 */
+EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp,
+ Tcl_Class clazz, Tcl_Method method);
+/* 28 */
+EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
+ Tcl_Object object);
+
+typedef struct TclOOStubHooks {
+ const struct TclOOIntStubs *tclOOIntStubs;
+} TclOOStubHooks;
+
+typedef struct TclOOStubs {
+ int magic;
+ const struct TclOOStubHooks *hooks;
+
+ Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */
+ Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */
+ Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
+ Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
+ Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
+ Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
+ Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
+ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
+ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
+ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */
+ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
+ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
+ Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
+ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
+ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
+ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
+ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
+ Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
+ int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
+ ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */
+ void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */
+ ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */
+ void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */
+ int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */
+ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
+ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */
+ void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
+ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
+ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
+} TclOOStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern const TclOOStubs *tclOOStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCLOO_STUBS)
+
+/*
+ * Inline function declarations:
+ */
+
+#define Tcl_CopyObjectInstance \
+ (tclOOStubsPtr->tcl_CopyObjectInstance) /* 0 */
+#define Tcl_GetClassAsObject \
+ (tclOOStubsPtr->tcl_GetClassAsObject) /* 1 */
+#define Tcl_GetObjectAsClass \
+ (tclOOStubsPtr->tcl_GetObjectAsClass) /* 2 */
+#define Tcl_GetObjectCommand \
+ (tclOOStubsPtr->tcl_GetObjectCommand) /* 3 */
+#define Tcl_GetObjectFromObj \
+ (tclOOStubsPtr->tcl_GetObjectFromObj) /* 4 */
+#define Tcl_GetObjectNamespace \
+ (tclOOStubsPtr->tcl_GetObjectNamespace) /* 5 */
+#define Tcl_MethodDeclarerClass \
+ (tclOOStubsPtr->tcl_MethodDeclarerClass) /* 6 */
+#define Tcl_MethodDeclarerObject \
+ (tclOOStubsPtr->tcl_MethodDeclarerObject) /* 7 */
+#define Tcl_MethodIsPublic \
+ (tclOOStubsPtr->tcl_MethodIsPublic) /* 8 */
+#define Tcl_MethodIsType \
+ (tclOOStubsPtr->tcl_MethodIsType) /* 9 */
+#define Tcl_MethodName \
+ (tclOOStubsPtr->tcl_MethodName) /* 10 */
+#define Tcl_NewInstanceMethod \
+ (tclOOStubsPtr->tcl_NewInstanceMethod) /* 11 */
+#define Tcl_NewMethod \
+ (tclOOStubsPtr->tcl_NewMethod) /* 12 */
+#define Tcl_NewObjectInstance \
+ (tclOOStubsPtr->tcl_NewObjectInstance) /* 13 */
+#define Tcl_ObjectDeleted \
+ (tclOOStubsPtr->tcl_ObjectDeleted) /* 14 */
+#define Tcl_ObjectContextIsFiltering \
+ (tclOOStubsPtr->tcl_ObjectContextIsFiltering) /* 15 */
+#define Tcl_ObjectContextMethod \
+ (tclOOStubsPtr->tcl_ObjectContextMethod) /* 16 */
+#define Tcl_ObjectContextObject \
+ (tclOOStubsPtr->tcl_ObjectContextObject) /* 17 */
+#define Tcl_ObjectContextSkippedArgs \
+ (tclOOStubsPtr->tcl_ObjectContextSkippedArgs) /* 18 */
+#define Tcl_ClassGetMetadata \
+ (tclOOStubsPtr->tcl_ClassGetMetadata) /* 19 */
+#define Tcl_ClassSetMetadata \
+ (tclOOStubsPtr->tcl_ClassSetMetadata) /* 20 */
+#define Tcl_ObjectGetMetadata \
+ (tclOOStubsPtr->tcl_ObjectGetMetadata) /* 21 */
+#define Tcl_ObjectSetMetadata \
+ (tclOOStubsPtr->tcl_ObjectSetMetadata) /* 22 */
+#define Tcl_ObjectContextInvokeNext \
+ (tclOOStubsPtr->tcl_ObjectContextInvokeNext) /* 23 */
+#define Tcl_ObjectGetMethodNameMapper \
+ (tclOOStubsPtr->tcl_ObjectGetMethodNameMapper) /* 24 */
+#define Tcl_ObjectSetMethodNameMapper \
+ (tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */
+#define Tcl_ClassSetConstructor \
+ (tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */
+#define Tcl_ClassSetDestructor \
+ (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
+#define Tcl_GetObjectName \
+ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */
+
+#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
new file mode 100644
index 0000000..72732da
--- /dev/null
+++ b/generic/tclOODefineCmds.c
@@ -0,0 +1,2001 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * 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-2008 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Forward declarations.
+ */
+
+static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
+static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
+ Tcl_Namespace *const namespacePtr);
+static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
+ Tcl_Obj *className, const char *errMsg);
+static inline int InitDefineContext(Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr, Object *oPtr,
+ int objc, Tcl_Obj *const objv[]);
+static inline void RecomputeClassCacheFlag(Object *oPtr);
+static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
+ int useClass, Tcl_Obj *const fromPtr,
+ Tcl_Obj *const toPtr);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * BumpGlobalEpoch --
+ * Utility that ensures that call chains that are invalid will get thrown
+ * away at an appropriate time. Note that exactly which epoch gets
+ * advanced will depend on exactly what the class is tangled up in; in
+ * the worst case, the simplest option is to advance the global epoch,
+ * causing *everything* to be thrown away on next usage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+BumpGlobalEpoch(
+ Tcl_Interp *interp,
+ Class *classPtr)
+{
+ if (classPtr != NULL
+ && classPtr->subclasses.num == 0
+ && classPtr->instances.num == 0
+ && classPtr->mixinSubs.num == 0) {
+ /*
+ * If a class has no subclasses or instances, and is not mixed into
+ * anything, a change to its structure does not require us to
+ * invalidate any call chains. Note that we still bump our object's
+ * epoch if it has any mixins; the relation between a class and its
+ * representative object is special. But it won't hurt.
+ */
+
+ if (classPtr->thisPtr->mixins.num > 0) {
+ classPtr->thisPtr->epoch++;
+ }
+ return;
+ }
+
+ /*
+ * Either there's no class (?!) or we're reconfiguring something that is
+ * in use. Force regeneration of call chains.
+ */
+
+ TclOOGetFoundation(interp)->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RecomputeClassCacheFlag --
+ * Determine whether the object is prototypical of its class, and hence
+ * able to use the class's method chain cache.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RecomputeClassCacheFlag(
+ Object *oPtr)
+{
+ if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0)
+ && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) {
+ oPtr->flags |= USE_CLASS_CACHE;
+ } else {
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetFilters --
+ * Install a list of filter method names into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetFilters(
+ Object *oPtr,
+ int numFilters,
+ Tcl_Obj *const *filters)
+{
+ int i;
+
+ if (oPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ }
+
+ if (numFilters == 0) {
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
+ ckfree(oPtr->filters.list);
+ oPtr->filters.list = NULL;
+ oPtr->filters.num = 0;
+ RecomputeClassCacheFlag(oPtr);
+ } else {
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
+ Tcl_Obj **filtersList;
+ int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+
+ if (oPtr->filters.num == 0) {
+ filtersList = ckalloc(size);
+ } else {
+ filtersList = ckrealloc(oPtr->filters.list, size);
+ }
+ for (i=0 ; i<numFilters ; i++) {
+ filtersList[i] = filters[i];
+ Tcl_IncrRefCount(filters[i]);
+ }
+ oPtr->filters.list = filtersList;
+ oPtr->filters.num = numFilters;
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ oPtr->epoch++; /* Only this object can be affected. */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetFilters --
+ * Install a list of filter method names into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetFilters(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ int numFilters,
+ Tcl_Obj *const *filters)
+{
+ int i;
+
+ if (classPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, classPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ }
+
+ if (numFilters == 0) {
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
+ ckfree(classPtr->filters.list);
+ classPtr->filters.list = NULL;
+ classPtr->filters.num = 0;
+ } else {
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
+ Tcl_Obj **filtersList;
+ int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+
+ if (classPtr->filters.num == 0) {
+ filtersList = ckalloc(size);
+ } else {
+ filtersList = ckrealloc(classPtr->filters.list, size);
+ }
+ for (i=0 ; i<numFilters ; i++) {
+ filtersList[i] = filters[i];
+ Tcl_IncrRefCount(filters[i]);
+ }
+ classPtr->filters.list = filtersList;
+ classPtr->filters.num = numFilters;
+ }
+
+ /*
+ * There may be many objects affected, so bump the global epoch.
+ */
+
+ BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetMixins --
+ * Install a list of mixin classes into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetMixins(
+ Object *oPtr,
+ int numMixins,
+ Class *const *mixins)
+{
+ Class *mixinPtr;
+ int i;
+
+ if (numMixins == 0) {
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ ckfree(oPtr->mixins.list);
+ oPtr->mixins.num = 0;
+ }
+ RecomputeClassCacheFlag(oPtr);
+ } else {
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ }
+ oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
+ sizeof(Class *) * numMixins);
+ } else {
+ oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ oPtr->mixins.num = numMixins;
+ memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOOAddToInstances(oPtr, mixinPtr);
+ }
+ }
+ }
+ oPtr->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetMixins --
+ * Install a list of mixin classes into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetMixins(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ int numMixins,
+ Class *const *mixins)
+{
+ Class *mixinPtr;
+ int i;
+
+ if (numMixins == 0) {
+ if (classPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ }
+ ckfree(classPtr->mixins.list);
+ classPtr->mixins.num = 0;
+ }
+ } else {
+ if (classPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ }
+ classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
+ sizeof(Class *) * numMixins);
+ } else {
+ classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ }
+ classPtr->mixins.num = numMixins;
+ memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOOAddToMixinSubs(classPtr, mixinPtr);
+ }
+ }
+ BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RenameDeleteMethod --
+ * Core of the code to rename and delete methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+RenameDeleteMethod(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ int useClass,
+ Tcl_Obj *const fromPtr,
+ Tcl_Obj *const toPtr)
+{
+ Tcl_HashEntry *hPtr, *newHPtr = NULL;
+ Method *mPtr;
+ int isNew;
+
+ if (!useClass) {
+ if (!oPtr->methodsPtr) {
+ noSuchMethod:
+ Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
+ " does not exist", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(fromPtr), NULL);
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
+ if (hPtr == NULL) {
+ goto noSuchMethod;
+ }
+ if (toPtr) {
+ newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr,
+ &isNew);
+ if (hPtr == newHPtr) {
+ renameToSelf:
+ Tcl_AppendResult(interp, "cannot rename method to itself",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
+ return TCL_ERROR;
+ } else if (!isNew) {
+ renameToExisting:
+ Tcl_AppendResult(interp, "method called ",
+ TclGetString(toPtr), " already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
+ return TCL_ERROR;
+ }
+ }
+ } else {
+ hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+ (char *) fromPtr);
+ if (hPtr == NULL) {
+ goto noSuchMethod;
+ }
+ if (toPtr) {
+ newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods,
+ (char *) toPtr, &isNew);
+ if (hPtr == newHPtr) {
+ goto renameToSelf;
+ } else if (!isNew) {
+ goto renameToExisting;
+ }
+ }
+ }
+
+ /*
+ * Complete the splicing by changing the method's name.
+ */
+
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (toPtr) {
+ Tcl_IncrRefCount(toPtr);
+ Tcl_DecrRefCount(mPtr->namePtr);
+ mPtr->namePtr = toPtr;
+ Tcl_SetHashValue(newHPtr, mPtr);
+ } else {
+ if (!useClass) {
+ RecomputeClassCacheFlag(oPtr);
+ }
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOUnknownDefinition --
+ * Handles what happens when an unknown command is encountered during the
+ * processing of a definition script. Works by finding a command in the
+ * operating definition namespace that the requested command is a unique
+ * prefix of.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOUnknownDefinition(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ int soughtLen;
+ const char *soughtStr, *matchedStr = NULL;
+
+ if (objc < 2) {
+ Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
+ return TCL_ERROR;
+ }
+ if (TclOOGetDefineCmdContext(interp) == NULL) {
+ return TCL_ERROR;
+ }
+
+ soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
+ if (soughtLen == 0) {
+ goto noMatch;
+ }
+ hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (hPtr != NULL) {
+ const char *nameStr = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+
+ if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
+ if (matchedStr != NULL) {
+ goto noMatch;
+ }
+ matchedStr = nameStr;
+ }
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+
+ if (matchedStr != NULL) {
+ /*
+ * Got one match, and only one match!
+ */
+
+ Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+ int result;
+
+ newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
+ Tcl_IncrRefCount(newObjv[0]);
+ if (objc > 2) {
+ memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+ }
+ result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+ Tcl_DecrRefCount(newObjv[0]);
+ TclStackFree(interp, newObjv);
+ return result;
+ }
+
+ noMatch:
+ Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindCommand --
+ * Specialized version of Tcl_FindCommand that handles command prefixes
+ * and disallows namespace magic.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Command
+FindCommand(
+ Tcl_Interp *interp,
+ Tcl_Obj *stringObj,
+ Tcl_Namespace *const namespacePtr)
+{
+ int length;
+ const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
+ register Namespace *const nsPtr = (Namespace *) namespacePtr;
+ FOREACH_HASH_DECLS;
+ Tcl_Command cmd, cmd2;
+
+ /*
+ * If someone is playing games, we stop playing right now.
+ */
+
+ if (string[0] == '\0' || strstr(string, "::") != NULL) {
+ return NULL;
+ }
+
+ /*
+ * Do the exact lookup first.
+ */
+
+ cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY);
+ if (cmd != NULL) {
+ return cmd;
+ }
+
+ /*
+ * Bother, need to perform an approximate match. Iterate across the hash
+ * table of commands in the namespace.
+ */
+
+ FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) {
+ if (strncmp(string, nameStr, length) == 0) {
+ if (cmd != NULL) {
+ return NULL;
+ }
+ cmd = cmd2;
+ }
+ }
+
+ /*
+ * Either we found one thing or we found nothing. Either way, return it.
+ */
+
+ return cmd;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitDefineContext --
+ * Does the magic incantations necessary to push the special stack frame
+ * used when processing object definitions. It is up to the caller to
+ * dispose of the frame (with TclPopStackFrame) when finished.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+InitDefineContext(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr,
+ Object *oPtr,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CallFrame *framePtr, **framePtrPtr = &framePtr;
+ int result;
+
+ if (namespacePtr == NULL) {
+ Tcl_AppendResult(interp,
+ "cannot process definitions; support namespace deleted",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ namespacePtr, FRAME_IS_OO_DEFINE);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->clientData = oPtr;
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineCmdContext --
+ * Extracts the magic token from the current stack frame, or returns NULL
+ * (and leaves an error message) otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+TclOOGetDefineCmdContext(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if ((iPtr->varFramePtr == NULL)
+ || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ Tcl_AppendResult(interp, "this command may only be called from within"
+ " the context of an ::oo::define or ::oo::objdefine command",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return NULL;
+ }
+ return (Tcl_Object) iPtr->varFramePtr->clientData;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * GetClassInOuterContext --
+ * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
+ * context that called oo::define (or equivalent). Note that this may
+ * have to go up multiple levels to get the level that we started doing
+ * definitions at.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Class *
+GetClassInOuterContext(
+ Tcl_Interp *interp,
+ Tcl_Obj *className,
+ const char *errMsg)
+{
+ Interp *iPtr = (Interp *) interp;
+ Object *oPtr;
+ CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+ if (iPtr->varFramePtr->callerVarPtr == NULL) {
+ Tcl_Panic("getting outer context when already in global context");
+ }
+ iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
+ iPtr->varFramePtr = savedFramePtr;
+ if (oPtr == NULL) {
+ return NULL;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, errMsg, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(className), NULL);
+ return NULL;
+ }
+ return oPtr->classPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineObjCmd --
+ * Implementation of the "oo::define" command. Works by effectively doing
+ * the same as 'namespace eval', but with extra magic applied so that the
+ * object to be modified is known to the commands in the target
+ * namespace. Also does ensemble-like tricks with dispatch so that error
+ * messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, TclGetString(objv[1]),
+ " does not refer to a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[1]), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::define namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 3) {
+ result = TclEvalObjEx(interp, objv[2], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 3;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 3) {
+ iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 2;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[2], fPtr->defineNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjDefObjCmd --
+ * Implementation of the "oo::objdefine" command. Works by effectively
+ * doing the same as 'namespace eval', but with extra magic applied so
+ * that the object to be modified is known to the commands in the target
+ * namespace. Also does ensemble-like tricks with dispatch so that error
+ * messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOObjDefObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::objdefine namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 3) {
+ result = TclEvalObjEx(interp, objv[2], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 3;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 3) {
+ iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 2;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSelfObjCmd --
+ * Implementation of the "self" subcommand of the "oo::define" command.
+ * Works by effectively doing the same as 'namespace eval', but with
+ * extra magic applied so that the object to be modified is known to the
+ * commands in the target namespace. Also does ensemble-like tricks with
+ * dispatch so that error messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::objdefine namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 2) {
+ result = TclEvalObjEx(interp, objv[1], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(
+ TclOOObjectName(interp, oPtr), &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 2;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 2) {
+ iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 1;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[1]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineClassObjCmd --
+ * Implementation of the "class" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Foundation *fPtr = TclOOGetFoundation(interp);
+
+ /*
+ * Parse the context to get the object to operate on.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & ROOT_OBJECT) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the root object class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & ROOT_CLASS) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the class of classes", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the argument to get the class to set the object's class to.
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassInOuterContext(interp, objv[1],
+ "the class of an object must be a class");
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Apply semantic checks. In particular, classes and non-classes are not
+ * interchangable (too complicated to do the conversion!) so we must
+ * produce an error if any attempt is made to swap from one to the other.
+ */
+
+ if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
+ Tcl_AppendResult(interp, "may not change a ",
+ (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
+ (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the object's class.
+ */
+
+ if (oPtr->selfCls != clsPtr) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ oPtr->selfCls = clsPtr;
+ TclOOAddToInstances(oPtr, oPtr->selfCls);
+ if (oPtr->classPtr != NULL) {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ } else {
+ oPtr->epoch++;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineConstructorObjCmd --
+ * Implementation of the "constructor" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineConstructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Method method;
+ int bodyLength;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Extract and validate the context, which is the class that we wish to
+ * modify.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ Tcl_GetStringFromObj(objv[2], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
+ PUBLIC_METHOD, NULL, objv[1], objv[2], NULL);
+ if (method == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Delete the constructor method record and set the field in the
+ * class record to NULL.
+ */
+
+ method = NULL;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might not
+ * immediately delete the constructor as this might be being done during
+ * execution of the constructor itself.
+ */
+
+ Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDeleteMethodObjCmd --
+ * Implementation of the "deletemethod" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDeleteMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceDeleteMethod = (clientData != NULL);
+ Object *oPtr;
+ int i;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceDeleteMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Delete the method structure from the appropriate hash table.
+ */
+
+ if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
+ objv[i], NULL) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (isInstanceDeleteMethod) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDestructorObjCmd --
+ * Implementation of the "destructor" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDestructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Method method;
+ int bodyLength;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "body");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ Tcl_GetStringFromObj(objv[1], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
+ PUBLIC_METHOD, NULL, NULL, objv[1], NULL);
+ if (method == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Delete the destructor method record and set the field in the class
+ * record to NULL.
+ */
+
+ method = NULL;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might not
+ * immediately delete the destructor as this might be being done during
+ * execution of the destructor itself. Also note that setting a
+ * destructor during a destructor is fairly dumb anyway.
+ */
+
+ Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineExportObjCmd --
+ * Implementation of the "export" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineExportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceExport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (!isInstanceExport && !clsPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Exporting is done by adding the PUBLIC_METHOD flag to the method
+ * record. If there is no such method in this object or class (i.e.
+ * the method comes from something inherited from or that we're an
+ * instance of) then we put in a blank record with that flag; such
+ * records are skipped over by the call chain engine *except* for
+ * their flags member.
+ */
+
+ if (isInstanceExport) {
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ mPtr->refCount = 1;
+ mPtr->namePtr = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+ mPtr->flags |= PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
+ /*
+ * Bump the right epoch if we actually changed anything.
+ */
+
+ if (changed) {
+ if (isInstanceExport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineFilterObjCmd --
+ * Implementation of the "filter" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineFilterObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceFilter = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceFilter && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ if (!isInstanceFilter) {
+ TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1);
+ } else {
+ TclOOObjectSetFilters(oPtr, objc-1, objv+1);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineForwardObjCmd --
+ * Implementation of the "forward" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineForwardObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceForward = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ int isPublic;
+ Tcl_Obj *prefixObj;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceForward && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ ? PUBLIC_METHOD : 0;
+
+ /*
+ * Create the method structure.
+ */
+
+ prefixObj = Tcl_NewListObj(objc-2, objv+2);
+ if (isInstanceForward) {
+ mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
+ prefixObj);
+ } else {
+ mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
+ objv[1], prefixObj);
+ }
+ if (mPtr == NULL) {
+ Tcl_DecrRefCount(prefixObj);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMethodObjCmd --
+ * Implementation of the "method" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceMethod = (clientData != NULL);
+ Object *oPtr;
+ int isPublic;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ ? PUBLIC_METHOD : 0;
+
+ /*
+ * Create the method by using the right back-end API.
+ */
+
+ if (isInstanceMethod) {
+ if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
+ objv[2], objv[3], NULL) == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
+ objv[2], objv[3], NULL) == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMixinObjCmd --
+ * Implementation of the "mixin" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMixinObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ const int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceMixin = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class **mixins;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceMixin && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
+
+ for (i=1 ; i<objc ; i++) {
+ Class *clsPtr = GetClassInOuterContext(interp, objv[i],
+ "may only mix in classes");
+
+ if (clsPtr == NULL) {
+ goto freeAndError;
+ }
+ if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
+ Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
+ goto freeAndError;
+ }
+ mixins[i-1] = clsPtr;
+ }
+
+ if (isInstanceMixin) {
+ TclOOObjectSetMixins(oPtr, objc-1, mixins);
+ } else {
+ TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
+ }
+
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineRenameMethodObjCmd --
+ * Implementation of the "renamemethod" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineRenameMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceRenameMethod = (clientData != NULL);
+ Object *oPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceRenameMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Delete the method entry from the appropriate hash table, and transfer
+ * the thing it points to to its new entry. To do this, we first need to
+ * get the entries from the appropriate hash tables (this can generate a
+ * range of errors...)
+ */
+
+ if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
+ objv[1], objv[2]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (isInstanceRenameMethod) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSuperclassObjCmd --
+ * Implementation of the "superclass" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSuperclassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class **superclasses, *superPtr;
+ int i, j;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the class to operate on.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only classes may have superclasses defined",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & ROOT_OBJECT) {
+ Tcl_AppendResult(interp,
+ "may not modify the superclass of the root object", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ superclasses = ckalloc(sizeof(Class *) * (objc-1));
+
+ /*
+ * Parse the arguments to get the class to use as superclasses.
+ */
+
+ for (i=0 ; i<objc-1 ; i++) {
+ Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
+ "only a class can be a superclass");
+
+ if (clsPtr == NULL) {
+ goto failedAfterAlloc;
+ }
+ for (j=0 ; j<i ; j++) {
+ if (superclasses[j] == clsPtr) {
+ Tcl_AppendResult(interp,
+ "class should only be a direct superclass once",NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
+ goto failedAfterAlloc;
+ }
+ }
+ if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
+ Tcl_AppendResult(interp,
+ "attempt to form circular dependency graph", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
+ failedAfterAlloc:
+ ckfree(superclasses);
+ return TCL_ERROR;
+ }
+ superclasses[i] = clsPtr;
+ }
+
+ /*
+ * Install the list of superclasses into the class. Note that this also
+ * involves splicing the class out of the superclasses' subclass list that
+ * it used to be a member of and splicing it into the new superclasses'
+ * subclass list.
+ */
+
+ if (oPtr->classPtr->superclasses.num != 0) {
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ }
+ ckfree(oPtr->classPtr->superclasses.list);
+ }
+ oPtr->classPtr->superclasses.list = superclasses;
+ oPtr->classPtr->superclasses.num = objc-1;
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+ }
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineUnexportObjCmd --
+ * Implementation of the "unexport" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineUnexportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceUnexport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (!isInstanceUnexport && !clsPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Unexporting is done by removing the PUBLIC_METHOD flag from the
+ * method record. If there is no such method in this object or class
+ * (i.e. the method comes from something inherited from or that we're
+ * an instance of) then we put in a blank record without that flag;
+ * such records are skipped over by the call chain engine *except* for
+ * their flags member.
+ */
+
+ if (isInstanceUnexport) {
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ mPtr->refCount = 1;
+ mPtr->namePtr = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || mPtr->flags & PUBLIC_METHOD) {
+ mPtr->flags &= ~PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
+ /*
+ * Bump the right epoch if we actually changed anything.
+ */
+
+ if (changed) {
+ if (isInstanceUnexport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineVariablesObjCmd --
+ * Implementation of the "variable" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineVariablesObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceVars = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceVars && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ const char *varName = Tcl_GetString(objv[i]);
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
+ }
+ }
+ for (i=1 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
+ if (!isInstanceVars) {
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree(oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list =
+ ckrealloc(oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->classPtr->variables.list =
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->classPtr->variables.list, objv+1,
+ sizeof(Tcl_Obj *) * (objc-1));
+ }
+ oPtr->classPtr->variables.num = objc-1;
+ } else {
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree(oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = ckrealloc(oPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->variables.list =
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
+ }
+ oPtr->variables.num = objc-1;
+ }
+ return TCL_OK;
+}
+
+void
+Tcl_ClassSetConstructor(
+ Tcl_Interp *interp,
+ Tcl_Class clazz,
+ Tcl_Method method)
+{
+ Class *clsPtr = (Class *) clazz;
+
+ if (method != (Tcl_Method) clsPtr->constructorPtr) {
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ clsPtr->constructorPtr = (Method *) method;
+
+ /*
+ * Remember to invalidate the cached constructor chain for this class.
+ * [Bug 2531577]
+ */
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ clsPtr->constructorChainPtr = NULL;
+ }
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+void
+Tcl_ClassSetDestructor(
+ Tcl_Interp *interp,
+ Tcl_Class clazz,
+ Tcl_Method method)
+{
+ Class *clsPtr = (Class *) clazz;
+
+ if (method != (Tcl_Method) clsPtr->destructorPtr) {
+ TclOODelMethodRef(clsPtr->destructorPtr);
+ clsPtr->destructorPtr = (Method *) method;
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ clsPtr->destructorChainPtr = NULL;
+ }
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
new file mode 100644
index 0000000..4f25772
--- /dev/null
+++ b/generic/tclOOInfo.c
@@ -0,0 +1,1464 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * This file contains the implementation of the ::oo-related [info]
+ * subcommands.
+ *
+ * Copyright (c) 2006-2008 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static Tcl_ObjCmdProc InfoObjectClassCmd;
+static Tcl_ObjCmdProc InfoObjectDefnCmd;
+static Tcl_ObjCmdProc InfoObjectFiltersCmd;
+static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIsACmd;
+static Tcl_ObjCmdProc InfoObjectMethodsCmd;
+static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
+static Tcl_ObjCmdProc InfoObjectMixinsCmd;
+static Tcl_ObjCmdProc InfoObjectNsCmd;
+static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoObjectVariablesCmd;
+static Tcl_ObjCmdProc InfoClassConstrCmd;
+static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDestrCmd;
+static Tcl_ObjCmdProc InfoClassFiltersCmd;
+static Tcl_ObjCmdProc InfoClassForwardCmd;
+static Tcl_ObjCmdProc InfoClassInstancesCmd;
+static Tcl_ObjCmdProc InfoClassMethodsCmd;
+static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
+static Tcl_ObjCmdProc InfoClassMixinsCmd;
+static Tcl_ObjCmdProc InfoClassSubsCmd;
+static Tcl_ObjCmdProc InfoClassSupersCmd;
+static Tcl_ObjCmdProc InfoClassVariablesCmd;
+
+struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
+
+/*
+ * List of commands that are used to implement the [info object] subcommands.
+ */
+
+static const struct NameProcMap infoObjectCmds[] = {
+ {"::oo::InfoObject::class", InfoObjectClassCmd},
+ {"::oo::InfoObject::definition", InfoObjectDefnCmd},
+ {"::oo::InfoObject::filters", InfoObjectFiltersCmd},
+ {"::oo::InfoObject::forward", InfoObjectForwardCmd},
+ {"::oo::InfoObject::isa", InfoObjectIsACmd},
+ {"::oo::InfoObject::methods", InfoObjectMethodsCmd},
+ {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd},
+ {"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
+ {"::oo::InfoObject::namespace", InfoObjectNsCmd},
+ {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
+ {"::oo::InfoObject::vars", InfoObjectVarsCmd},
+ {NULL, NULL}
+};
+
+/*
+ * List of commands that are used to implement the [info class] subcommands.
+ */
+
+static const struct NameProcMap infoClassCmds[] = {
+ {"::oo::InfoClass::constructor", InfoClassConstrCmd},
+ {"::oo::InfoClass::definition", InfoClassDefnCmd},
+ {"::oo::InfoClass::destructor", InfoClassDestrCmd},
+ {"::oo::InfoClass::filters", InfoClassFiltersCmd},
+ {"::oo::InfoClass::forward", InfoClassForwardCmd},
+ {"::oo::InfoClass::instances", InfoClassInstancesCmd},
+ {"::oo::InfoClass::methods", InfoClassMethodsCmd},
+ {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd},
+ {"::oo::InfoClass::mixins", InfoClassMixinsCmd},
+ {"::oo::InfoClass::subclasses", InfoClassSubsCmd},
+ {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+ {"::oo::InfoClass::variables", InfoClassVariablesCmd},
+ {NULL, NULL}
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInitInfo --
+ *
+ * Adjusts the Tcl core [info] command to contain subcommands ("object"
+ * and "class") for introspection of objects and classes.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOInitInfo(
+ Tcl_Interp *interp)
+{
+ Tcl_Namespace *nsPtr;
+ Tcl_Command infoCmd;
+ int i;
+
+ /*
+ * Build the ensemble used to implement [info object].
+ */
+
+ nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
+ Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+ Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+ for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
+ Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
+ infoObjectCmds[i].proc, NULL, NULL);
+ }
+
+ /*
+ * Build the ensemble used to implement [info class].
+ */
+
+ nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
+ Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+ Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+ for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
+ Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
+ infoClassCmds[i].proc, NULL, NULL);
+ }
+
+ /*
+ * Install into the master [info] ensemble.
+ */
+
+ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
+ if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) {
+ Tcl_Obj *mapDict, *objectObj, *classObj;
+
+ Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
+ if (mapDict != NULL) {
+ objectObj = Tcl_NewStringObj("object", -1);
+ classObj = Tcl_NewStringObj("class", -1);
+
+ Tcl_IncrRefCount(objectObj);
+ Tcl_IncrRefCount(classObj);
+ Tcl_DictObjPut(NULL, mapDict, objectObj,
+ Tcl_NewStringObj("::oo::InfoObject", -1));
+ Tcl_DictObjPut(NULL, mapDict, classObj,
+ Tcl_NewStringObj("::oo::InfoClass", -1));
+ Tcl_DecrRefCount(objectObj);
+ Tcl_DecrRefCount(classObj);
+ Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * GetClassFromObj --
+ *
+ * How to correctly get a class from a Tcl_Obj. Just a wrapper round
+ * Tcl_GetObjectFromObj, but this is an idiom that was used heavily.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Class *
+GetClassFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
+{
+ Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
+
+ if (oPtr == NULL) {
+ return NULL;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
+ "\" is not a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objPtr), NULL);
+ return NULL;
+ }
+ return oPtr->classPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectClassCmd --
+ *
+ * Implements [info object class $objName ?$className?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectClassCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ Tcl_SetObjResult(interp,
+ TclOOObjectName(interp, oPtr->selfCls->thisPtr));
+ return TCL_OK;
+ } else {
+ Class *mixinPtr, *o2clsPtr;
+ int i;
+
+ o2clsPtr = GetClassFromObj(interp, objv[2]);
+ if (o2clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
+ return TCL_OK;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectDefnCmd --
+ *
+ * Implements [info object definition $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectDefnCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *resultObjs[2];
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (!oPtr->methodsPtr) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ resultObjs[0] = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ 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, resultObjs[0], argObj);
+ }
+ }
+ resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectFiltersCmd --
+ *
+ * Implements [info object filters $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectFiltersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj, *resultObj;
+ Object *oPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewObj();
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectForwardCmd --
+ *
+ * Implements [info object forward $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectForwardCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (!oPtr->methodsPtr) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectIsACmd --
+ *
+ * Implements [info object isa $category $objName ...]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIsACmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *const categories[] = {
+ "class", "metaclass", "mixin", "object", "typeof", NULL
+ };
+ enum IsACats {
+ IsClass, IsMetaclass, IsMixin, IsObject, IsType
+ };
+ Object *oPtr, *o2Ptr;
+ int idx, i;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (idx == IsObject) {
+ int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
+
+ if (!ok) {
+ Tcl_ResetResult(interp);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
+ return TCL_OK;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum IsACats) idx) {
+ case IsClass:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
+ return TCL_OK;
+ case IsMetaclass:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName");
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ } else {
+ Class *classCls = TclOOGetFoundation(interp)->classCls;
+
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0));
+ }
+ return TCL_OK;
+ case IsMixin:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
+ return TCL_ERROR;
+ } else {
+ Class *mixinPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr == o2Ptr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ return TCL_OK;
+ case IsType:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+ if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ }
+ return TCL_OK;
+ case IsObject:
+ Tcl_Panic("unexpected fallthrough");
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMethodsCmd --
+ *
+ * Implements [info object methods $objName ?$option ...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMethodsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int flag = PUBLIC_METHOD, recurse = 0;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr, *resultObj;
+ Method *mPtr;
+ static const char *const options[] = {
+ "-all", "-localprivate", "-private", NULL
+ };
+ enum Options {
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc != 2) {
+ int i, idx;
+
+ for (i=2 ; i<objc ; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) idx) {
+ case OPT_ALL:
+ recurse = 1;
+ break;
+ case OPT_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case OPT_PRIVATE:
+ flag = 0;
+ break;
+ }
+ }
+ }
+
+ resultObj = Tcl_NewObj();
+ if (recurse) {
+ const char **names;
+ int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+
+ for (i=0 ; i<numNames ; i++) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(names[i], -1));
+ }
+ if (numNames > 0) {
+ ckfree(names);
+ }
+ } else if (oPtr->methodsPtr) {
+ FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMethodTypeCmd --
+ *
+ * Implements [info object methodtype $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMethodTypeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_HashEntry *hPtr;
+ Method *mPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (!oPtr->methodsPtr) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr == NULL) {
+ /*
+ * Special entry for visibility control: pretend the method doesnt
+ * exist.
+ */
+
+ goto unknownMethod;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMixinsCmd --
+ *
+ * Implements [info object mixins $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMixinsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *mixinPtr;
+ Object *oPtr;
+ Tcl_Obj *resultObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectNsCmd --
+ *
+ * Implements [info object namespace $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectNsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectVariablesCmd --
+ *
+ * Implements [info object variables $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_Obj *variableObj, *resultObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectVarsCmd --
+ *
+ * Implements [info object vars $objName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVarsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ const char *pattern = NULL;
+ FOREACH_HASH_DECLS;
+ VarInHash *vihPtr;
+ Tcl_Obj *nameObj, *resultObj;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+ resultObj = Tcl_NewObj();
+
+ /*
+ * Extract the information we need from the object's namespace's table of
+ * variables. Note that this involves horrific knowledge of the guts of
+ * tclVar.c, so we can't leverage our hash-iteration macros properly.
+ */
+
+ FOREACH_HASH_VALUE(vihPtr,
+ &((Namespace *) oPtr->namespacePtr)->varTable.table) {
+ nameObj = vihPtr->entry.key.objPtr;
+
+ if (TclIsVarUndefined(&vihPtr->var)
+ || !TclIsVarNamespaceVar(&vihPtr->var)) {
+ continue;
+ }
+ if (pattern != NULL
+ && !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
+ }
+
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassConstrCmd --
+ *
+ * Implements [info class constructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassConstrCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *resultObjs[2];
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (clsPtr->constructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObjs[0] = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ 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, resultObjs[0], argObj);
+ }
+ }
+ resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDefnCmd --
+ *
+ * Implements [info class definition $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *resultObjs[2];
+ Class *clsPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ resultObjs[0] = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ 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, resultObjs[0], argObj);
+ }
+ }
+ resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDestrCmd --
+ *
+ * Implements [info class destructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDestrCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (clsPtr->destructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassFiltersCmd --
+ *
+ * Implements [info class filters $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassFiltersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj, *resultObj;
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassForwardCmd --
+ *
+ * Implements [info class forward $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassForwardCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+ Class *clsPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassInstancesCmd --
+ *
+ * Implements [info class instances $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassInstancesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr;
+ int i;
+ const char *pattern = NULL;
+ Tcl_Obj *resultObj;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(oPtr, clsPtr->instances) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMethodsCmd --
+ *
+ * Implements [info class methods $clsName ?-private?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMethodsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int flag = PUBLIC_METHOD, recurse = 0;
+ Tcl_Obj *namePtr, *resultObj;
+ Method *mPtr;
+ Class *clsPtr;
+ static const char *const options[] = {
+ "-all", "-localprivate", "-private", NULL
+ };
+ enum Options {
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc != 2) {
+ int i, idx;
+
+ for (i=2 ; i<objc ; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) idx) {
+ case OPT_ALL:
+ recurse = 1;
+ break;
+ case OPT_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case OPT_PRIVATE:
+ flag = 0;
+ break;
+ }
+ }
+ }
+
+ resultObj = Tcl_NewObj();
+ if (recurse) {
+ const char **names;
+ int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
+
+ for (i=0 ; i<numNames ; i++) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(names[i], -1));
+ }
+ if (numNames > 0) {
+ ckfree(names);
+ }
+ } else {
+ FOREACH_HASH_DECLS;
+
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMethodTypeCmd --
+ *
+ * Implements [info class methodtype $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMethodTypeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Method *mPtr;
+ Class *clsPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr == NULL) {
+ /*
+ * Special entry for visibility control: pretend the method doesnt
+ * exist.
+ */
+
+ goto unknownMethod;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMixinsCmd --
+ *
+ * Implements [info class mixins $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMixinsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr, *mixinPtr;
+ Tcl_Obj *resultObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSubsCmd --
+ *
+ * Implements [info class subclasses $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSubsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr, *subclassPtr;
+ Tcl_Obj *resultObj;
+ int i;
+ const char *pattern = NULL;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
+ }
+ FOREACH(subclassPtr, clsPtr->mixinSubs) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSupersCmd --
+ *
+ * Implements [info class superclasses $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSupersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr, *superPtr;
+ Tcl_Obj *resultObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(superPtr, clsPtr->superclasses) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, superPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassVariablesCmd --
+ *
+ * Implements [info class variables $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr;
+ Tcl_Obj *variableObj, *resultObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
new file mode 100644
index 0000000..bd32f22
--- /dev/null
+++ b/generic/tclOOInt.h
@@ -0,0 +1,626 @@
+/*
+ * tclOOInt.h --
+ *
+ * This file contains the structure definitions and some of the function
+ * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006-2011 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.
+ */
+
+#ifndef TCL_OO_INTERNAL_H
+#define TCL_OO_INTERNAL_H 1
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+/*
+ * Hack to make things work with Objective C. Note that ObjC isn't really
+ * supported, but we don't want to to be actively hostile to it. [Bug 2163447]
+ */
+
+#ifdef __OBJC__
+#define Class TclOOClass
+#define Object TclOOObject
+#endif /* __OBJC__ */
+
+/*
+ * Forward declarations.
+ */
+
+struct CallChain;
+struct Class;
+struct Foundation;
+struct Object;
+
+/*
+ * The data that needs to be stored per method. This record is used to collect
+ * information about all sorts of methods, including forwards, constructors
+ * and destructors.
+ */
+
+typedef struct Method {
+ const Tcl_MethodType *typePtr;
+ /* The type of method. If NULL, this is a
+ * special flag record which is just used for
+ * the setting of the flags field. */
+ int refCount;
+ ClientData clientData; /* Type-specific data. */
+ Tcl_Obj *namePtr; /* Name of the method. */
+ struct Object *declaringObjectPtr;
+ /* The object that declares this method, or
+ * NULL if it was declared by a class. */
+ struct Class *declaringClassPtr;
+ /* The class that declares this method, or
+ * NULL if it was declared directly on an
+ * object. */
+ int flags; /* Assorted flags. Includes whether this
+ * method is public/exported or not. */
+} Method;
+
+/*
+ * Pre- and post-call callbacks, to allow procedure-like methods to be fine
+ * tuned in their behaviour.
+ */
+
+typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
+typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
+typedef void (TclOO_PmCDDeleteProc)(ClientData clientData);
+typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData);
+
+/*
+ * Procedure-like methods have the following extra information.
+ */
+
+typedef struct ProcedureMethod {
+ int version; /* Version of this structure. Currently must
+ * be 0. */
+ Proc *procPtr; /* Core of the implementation of the method;
+ * includes the argument definition and the
+ * body bytecodes. */
+ int flags; /* Flags to control features. */
+ int refCount;
+ ClientData clientData;
+ TclOO_PmCDDeleteProc *deleteClientdataProc;
+ TclOO_PmCDCloneProc *cloneClientdataProc;
+ ProcErrorProc *errProc; /* Replacement error handler. */
+ TclOO_PreCallProc *preCallProc;
+ /* Callback to allow for additional setup
+ * before the method executes. */
+ TclOO_PostCallProc *postCallProc;
+ /* Callback to allow for additional cleanup
+ * after the method executes. */
+ GetFrameInfoValueProc *gfivProc;
+ /* Callback to allow for fine tuning of how
+ * the method reports itself. */
+} ProcedureMethod;
+
+#define TCLOO_PROCEDURE_METHOD_VERSION 0
+
+/*
+ * Flags for use in a ProcedureMethod.
+ *
+ * When the USE_DECLARER_NS flag is set, the method will use the namespace of
+ * the object or class that declared it (or the clone of it, if it was from
+ * such that the implementation of the method came to the particular use)
+ * instead of the namespace of the object on which the method was invoked.
+ * This flag must be distinct from all others that are associated with
+ * methods.
+ */
+
+#define USE_DECLARER_NS 0x80
+
+/*
+ * Forwarded methods have the following extra information.
+ */
+
+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;
+
+/*
+ * Helper definitions that declare a "list" array. The two varieties are
+ * either optimized for simplicity (in the case that the whole array is
+ * typically assigned at once) or efficiency (in the case that the array is
+ * expected to be expanded over time). These lists are designed to be iterated
+ * over with the help of the FOREACH macro (see later in this file).
+ *
+ * The "num" field always counts the number of listType_t elements used in the
+ * "list" field. When a "size" field exists, it describes how many elements
+ * are present in the list; when absent, exactly "num" elements are present.
+ */
+
+#define LIST_STATIC(listType_t) \
+ struct { int num; listType_t *list; }
+#define LIST_DYNAMIC(listType_t) \
+ struct { int num, size; listType_t *list; }
+
+/*
+ * Now, the definition of what an object actually is.
+ */
+
+typedef struct Object {
+ struct Foundation *fPtr; /* The basis for the object system. Putting
+ * this here allows the avoidance of quite a
+ * lot of hash lookups on the critical path
+ * for object invokation and creation. */
+ Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
+ Tcl_Command command; /* Reference to this object's public
+ * command. */
+ Tcl_Command myCommand; /* Reference to this object's internal
+ * command. */
+ struct Class *selfCls; /* This object's class. */
+ Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to
+ * Method* mapping. */
+ LIST_STATIC(struct Class *) mixins;
+ /* Classes mixed into this object. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names. */
+ struct Class *classPtr; /* All classes have this non-NULL; it points
+ * to the class structure. Everything else has
+ * this NULL. */
+ int refCount; /* Number of strong references to this object.
+ * Note that there may be many more weak
+ * references; this mechanism is there to
+ * avoid Tcl_Preserve. */
+ int flags;
+ int creationEpoch; /* Unique value to make comparisons of objects
+ * easier. */
+ int epoch; /* Per-object epoch, incremented when the way
+ * an object should resolve call chains is
+ * changed. */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+ Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
+ Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table
+ * is indexed by method name as Tcl_Obj. */
+ Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
+ /* Function to allow remapping of method
+ * names. For itcl-ng. */
+ LIST_STATIC(Tcl_Obj *) variables;
+} Object;
+
+#define OBJECT_DELETED 1 /* Flag to say that an object has been
+ * destroyed. */
+#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
+ * called. */
+#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
+ * the class hierarchy and should be treated
+ * specially during teardown. */
+#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
+ * filter; when set, filters are *not*
+ * processed on the object, preventing nasty
+ * recursive filtering problems. */
+#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure
+ * instance of the class, and has had nothing
+ * added that changes the dispatch chain (i.e.
+ * no methods, mixins, or filters. */
+#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root
+ * class of classes, and should be treated
+ * specially during teardown (and in a few
+ * other spots). */
+
+/*
+ * And the definition of a class. Note that every class also has an associated
+ * object, through which it is manipulated.
+ */
+
+typedef struct Class {
+ Object *thisPtr; /* Reference to the object associated with
+ * this class. */
+ int refCount; /* Number of strong references to this class.
+ * Weak references are not counted; the
+ * purpose of this is to avoid Tcl_Preserve as
+ * that is quite slow. */
+ int flags; /* Assorted flags. */
+ LIST_STATIC(struct Class *) superclasses;
+ /* List of superclasses, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) subclasses;
+ /* List of subclasses, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_DYNAMIC(Object *) instances;
+ /* List of instances, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names, used for generation
+ * of method call chains. */
+ LIST_STATIC(struct Class *) mixins;
+ /* List of mixin classes, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) mixinSubs;
+ /* List of classes that this class is mixed
+ * into, used to ensure deletion of dependent
+ * entities happens properly when the class
+ * itself is deleted. */
+ Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
+ * the (Tcl_Obj*) method name to the (Method*)
+ * method record. */
+ Method *constructorPtr; /* Method record of the class constructor (if
+ * any). */
+ Method *destructorPtr; /* Method record of the class destructor (if
+ * any). */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+ struct CallChain *constructorChainPtr;
+ struct CallChain *destructorChainPtr;
+ Tcl_HashTable *classChainCache;
+ /* Places where call chains are stored. For
+ * constructors, the class chain is always
+ * used. For destructors and ordinary methods,
+ * the class chain is only used when the
+ * object doesn't override with its own mixins
+ * (and filters and method implementations for
+ * when getting method chains). */
+ LIST_STATIC(Tcl_Obj *) variables;
+} Class;
+
+/*
+ * The foundation of the object system within an interpreter contains
+ * references to the key classes and namespaces, together with a few other
+ * useful bits and pieces. Probably ought to eventually go in the Interp
+ * structure itself.
+ */
+
+typedef struct ThreadLocalData {
+ int nsCount; /* Master epoch counter is used for keeping
+ * the values used in Tcl_Obj internal
+ * representations sane. Must be thread-local
+ * because Tcl_Objs can cross interpreter
+ * boundaries within a thread (objects don't
+ * generally cross threads). */
+} ThreadLocalData;
+
+typedef struct Foundation {
+ Tcl_Interp *interp;
+ Class *objectCls; /* The root of the object system. */
+ Class *classCls; /* The class of all classes. */
+ Tcl_Namespace *ooNs; /* Master ::oo namespace. */
+ Tcl_Namespace *defineNs; /* Namespace containing special commands for
+ * manipulating objects and classes. The
+ * "oo::define" command acts as a special kind
+ * of ensemble for this namespace. */
+ Tcl_Namespace *objdefNs; /* Namespace containing special commands for
+ * manipulating objects and classes. The
+ * "oo::objdefine" command acts as a special
+ * kind of ensemble for this namespace. */
+ Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
+ * only valid when executing inside a
+ * procedural method. */
+ int epoch; /* Used to invalidate method chains when the
+ * class structure changes. */
+ ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
+ * namespace to each object. */
+ Tcl_Obj *unknownMethodNameObj;
+ /* Shared object containing the name of the
+ * unknown method handler method. */
+ Tcl_Obj *constructorName; /* Shared object containing the "name" of a
+ * constructor. */
+ Tcl_Obj *destructorName; /* Shared object containing the "name" of a
+ * destructor. */
+} Foundation;
+
+/*
+ * A call context structure is built when a method is called. They contain the
+ * chain of method implementations that are to be invoked by a particular
+ * call, and the process of calling walks the chain, with the [next] command
+ * proceeding to the next entry in the chain.
+ */
+
+#define CALL_CHAIN_STATIC_SIZE 4
+
+struct MInvoke {
+ Method *mPtr; /* Reference to the method implementation
+ * record. */
+ int isFilter; /* Whether this is a filter invokation. */
+ Class *filterDeclarer; /* What class decided to add the filter; if
+ * NULL, it was added by the object. */
+};
+
+typedef struct CallChain {
+ int objectCreationEpoch; /* The object's creation epoch. Note that the
+ * object reference is not stored in the call
+ * chain; it is in the call context. */
+ int objectEpoch; /* Local (object structure) epoch counter
+ * snapshot. */
+ int epoch; /* Global (class structure) epoch counter
+ * snapshot. */
+ int flags; /* Assorted flags, see below. */
+ int refCount; /* Reference count. */
+ int numChain; /* Size of the call chain. */
+ struct MInvoke *chain; /* Array of call chain entries. May point to
+ * staticChain if the number of entries is
+ * small. */
+ struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
+} CallChain;
+
+typedef struct CallContext {
+ Object *oPtr; /* The object associated with this call. */
+ int index; /* Index into the call chain of the currently
+ * executing method implementation. */
+ int skip; /* Current number of arguments to skip; can
+ * vary depending on whether it is a direct
+ * method call or a continuation via the
+ * [next] command. */
+ CallChain *callPtr; /* The actual call chain. */
+} CallContext;
+
+/*
+ * Bits for the 'flags' field of the call chain.
+ */
+
+#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */
+#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances
+ * only) method. */
+#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
+#define CONSTRUCTOR 0x08 /* This is a constructor. */
+#define DESTRUCTOR 0x10 /* This is a destructor. */
+
+/*
+ * Assorted flags for call frames. Note that bits 1 and 2 are already taken by
+ * Tcl itself.
+ */
+
+#if 0
+#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
+ * clientData field contains a CallContext
+ * reference. */
+#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
+ * the [oo::define] command; the clientData
+ * field contains an Object reference that has
+ * been confirmed to refer to a class. */
+#endif
+
+/*
+ * Structure containing definition information about basic class methods.
+ */
+
+typedef struct {
+ const char *name; /* Name of the method in question. */
+ int isPublic; /* Whether the method is public by default. */
+ Tcl_MethodType definition; /* How to call the method. */
+} DeclaredClassMethod;
+
+/*
+ *----------------------------------------------------------------
+ * Commands relating to OO support.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData,
+ Tcl_Interp *interp, const int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineVariablesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOONextObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+/*
+ * Method implementations (in tclOOBasic.c).
+ */
+
+MODULE_SCOPE int TclOO_Class_Create(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Class_New(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * Private definitions, some of which perhaps ought to be exposed properly or
+ * maybe just put in the internal stubs table.
+ */
+
+MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
+MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
+ Tcl_Class cls, const char *nameStr,
+ const char *nsNameStr, int objc,
+ Tcl_Obj *const *objv, int skip,
+ Tcl_Object *objectPtr);
+MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
+MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
+MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
+MODULE_SCOPE void TclOODelMethodRef(Method *method);
+MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
+ Tcl_Obj *methodNameObj, int flags,
+ Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
+MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
+MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
+ int flags, const char ***stringsPtr);
+MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
+ const char ***stringsPtr);
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
+MODULE_SCOPE int TclOOInvokeContext(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const *objv, int skip);
+MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
+ const DeclaredClassMethod *dcm);
+MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
+MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
+ Class *mixinPtr);
+MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
+ Class *superPtr);
+MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
+ CallContext *contextPtr);
+MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
+MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
+/*
+ * Include all the private API, generated from tclOO.decls.
+ */
+
+#include "tclOOIntDecls.h"
+
+/*
+ * A convenience macro for iterating through the lists used in the internal
+ * memory management of objects. This is a bit gnarly because we want to do
+ * the assignment of the picked-out value only when the body test succeeds,
+ * but we cannot rely on the assigned value being useful, forcing us to do
+ * some nasty stuff with the comma operator. The compiler's optimizer should
+ * be able to sort it all out!
+ *
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH(var,ary) \
+ for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+
+/*
+ * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
+ * sets up the declarations needed for the main macro, FOREACH_HASH, which
+ * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
+ * only iterates over values.
+ */
+
+#define FOREACH_HASH_DECLS \
+ Tcl_HashEntry *hPtr;Tcl_HashSearch search
+#define FOREACH_HASH(key,val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
+ (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
+#define FOREACH_HASH_VALUE(val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
+
+/*
+ * Convenience macro for duplicating a list. Needs no external declaration,
+ * but all arguments are used multiple times and so must have no side effects.
+ */
+
+#undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */
+#define DUPLICATE(target,source,type) \
+ do { \
+ register unsigned len = sizeof(type) * ((target).num=(source).num);\
+ if (len != 0) { \
+ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
+ } else { \
+ (target).list = NULL; \
+ } \
+ } while(0)
+
+/*
+ * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
+ */
+
+#define AddRef(ptr) ((ptr)->refCount++)
+#define DelRef(ptr) do { \
+ if (--(ptr)->refCount < 1) { \
+ ckfree((char *) (ptr)); \
+ } \
+ } while(0)
+
+#endif /* TCL_OO_INTERNAL_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
new file mode 100644
index 0000000..b9600f2
--- /dev/null
+++ b/generic/tclOOIntDecls.h
@@ -0,0 +1,184 @@
+/*
+ * This file is (mostly) automatically generated from tclOO.decls.
+ */
+
+#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
+
+/*
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tclOO.decls script.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp);
+/* 1 */
+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 */
+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 */
+EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp,
+ Object *oPtr, int flags, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr);
+/* 4 */
+EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+ int flags, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr);
+/* 5 */
+EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv,
+ int publicOnly, Class *startCls);
+/* 6 */
+EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr);
+/* 7 */
+EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp,
+ Class *clsPtr, int isPublic,
+ Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
+/* 8 */
+EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp,
+ Object *oPtr, int isPublic, Tcl_Obj *nameObj,
+ Tcl_Obj *prefixObj);
+/* 9 */
+EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+ Tcl_Object oPtr,
+ TclOO_PreCallProc *preCallPtr,
+ TclOO_PostCallProc *postCallPtr,
+ ProcErrorProc *errProc,
+ ClientData clientData, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ int flags, void **internalTokenPtr);
+/* 10 */
+EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp,
+ Tcl_Class clsPtr,
+ TclOO_PreCallProc *preCallPtr,
+ TclOO_PostCallProc *postCallPtr,
+ ProcErrorProc *errProc,
+ ClientData clientData, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ int flags, void **internalTokenPtr);
+/* 11 */
+EXTERN int TclOOInvokeObject(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Class startCls,
+ int publicPrivate, int objc,
+ Tcl_Obj *const *objv);
+/* 12 */
+EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters,
+ Tcl_Obj *const *filters);
+/* 13 */
+EXTERN void TclOOClassSetFilters(Tcl_Interp *interp,
+ Class *classPtr, int numFilters,
+ Tcl_Obj *const *filters);
+/* 14 */
+EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins,
+ Class *const *mixins);
+/* 15 */
+EXTERN void TclOOClassSetMixins(Tcl_Interp *interp,
+ Class *classPtr, int numMixins,
+ Class *const *mixins);
+
+typedef struct TclOOIntStubs {
+ int magic;
+ const struct TclOOIntStubHooks *hooks;
+
+ Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
+ 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); /* 1 */
+ 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); /* 2 */
+ Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */
+ Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */
+ int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */
+ int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */
+ Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */
+ Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */
+ Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */
+ Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */
+ int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */
+ void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */
+ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */
+ void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */
+ 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
+
+#if defined(USE_TCLOO_STUBS)
+
+/*
+ * Inline function declarations:
+ */
+
+#define TclOOGetDefineCmdContext \
+ (tclOOIntStubsPtr->tclOOGetDefineCmdContext) /* 0 */
+#define TclOOMakeProcInstanceMethod \
+ (tclOOIntStubsPtr->tclOOMakeProcInstanceMethod) /* 1 */
+#define TclOOMakeProcMethod \
+ (tclOOIntStubsPtr->tclOOMakeProcMethod) /* 2 */
+#define TclOONewProcInstanceMethod \
+ (tclOOIntStubsPtr->tclOONewProcInstanceMethod) /* 3 */
+#define TclOONewProcMethod \
+ (tclOOIntStubsPtr->tclOONewProcMethod) /* 4 */
+#define TclOOObjectCmdCore \
+ (tclOOIntStubsPtr->tclOOObjectCmdCore) /* 5 */
+#define TclOOIsReachable \
+ (tclOOIntStubsPtr->tclOOIsReachable) /* 6 */
+#define TclOONewForwardMethod \
+ (tclOOIntStubsPtr->tclOONewForwardMethod) /* 7 */
+#define TclOONewForwardInstanceMethod \
+ (tclOOIntStubsPtr->tclOONewForwardInstanceMethod) /* 8 */
+#define TclOONewProcInstanceMethodEx \
+ (tclOOIntStubsPtr->tclOONewProcInstanceMethodEx) /* 9 */
+#define TclOONewProcMethodEx \
+ (tclOOIntStubsPtr->tclOONewProcMethodEx) /* 10 */
+#define TclOOInvokeObject \
+ (tclOOIntStubsPtr->tclOOInvokeObject) /* 11 */
+#define TclOOObjectSetFilters \
+ (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */
+#define TclOOClassSetFilters \
+ (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */
+#define TclOOObjectSetMixins \
+ (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */
+#define TclOOClassSetMixins \
+ (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */
+
+#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
new file mode 100644
index 0000000..4e7edb8
--- /dev/null
+++ b/generic/tclOOMethod.c
@@ -0,0 +1,1755 @@
+/*
+ * tclOOMethod.c --
+ *
+ * This file contains code to create and manage methods.
+ *
+ * Copyright (c) 2005-2008 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.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+#include "tclCompile.h"
+
+/*
+ * Structure used to help delay computing names of objects or classes for
+ * [info frame] until needed, making invokation faster in the normal case.
+ */
+
+struct PNI {
+ Tcl_Interp *interp; /* Interpreter in which to compute the name of
+ * a method. */
+ Tcl_Method method; /* Method to compute the name of. */
+};
+
+/*
+ * Structure used to contain all the information needed about a call frame
+ * used in a procedure-like method.
+ */
+
+typedef struct {
+ CallFrame *framePtr; /* Reference to the call frame itself (it's
+ * actually allocated on the Tcl stack). */
+ ProcErrorProc *errProc; /* The error handler for the body. */
+ Tcl_Obj *nameObj; /* The "name" of the command. */
+ Command cmd; /* The command structure. Mostly bogus. */
+ ExtraFrameInfo efi; /* Extra information used for [info frame]. */
+ Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a
+ * recursive call returns. */
+ struct PNI pni; /* Specialist information used in the efi
+ * field for this type of call. */
+} PMFrameData;
+
+/*
+ * Structure used to pass information about variable resolution to the
+ * on-the-ground resolvers used when working with resolved compiled variables.
+ */
+
+typedef struct {
+ Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
+ * variable can be linked to the namespace
+ * variable at the right time. */
+ Tcl_Obj *variableObj; /* The name of the variable. */
+ Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
+ * variables be cached? */
+} OOResVarInfo;
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int toRewrite,
+ int rewriteLength, Tcl_Obj *const *rewriteObjs,
+ int *lengthPtr);
+static int InvokeProcedureMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int FinalizePMCall(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int PushMethodCallFrame(Tcl_Interp *interp,
+ CallContext *contextPtr, ProcedureMethod *pmPtr,
+ int objc, Tcl_Obj *const *objv,
+ PMFrameData *fdPtr);
+static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
+static void DeleteProcedureMethod(ClientData clientData);
+static int CloneProcedureMethod(Tcl_Interp *interp,
+ ClientData clientData, ClientData *newClientData);
+static void MethodErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static void ConstructorErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static void DestructorErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static Tcl_Obj * RenderDeclarerName(ClientData clientData);
+static int InvokeForwardMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static void DeleteForwardMethod(ClientData clientData);
+static int CloneForwardMethod(Tcl_Interp *interp,
+ ClientData clientData, ClientData *newClientData);
+static int ProcedureMethodVarResolver(Tcl_Interp *interp,
+ const char *varName, Tcl_Namespace *contextNs,
+ int flags, Tcl_Var *varPtr);
+static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
+ const char *varName, int length,
+ Tcl_Namespace *contextNs,
+ Tcl_ResolvedVarInfo **rPtrPtr);
+
+/*
+ * The types of methods defined by the core OO system.
+ */
+
+static const Tcl_MethodType procMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "method",
+ InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
+};
+static const Tcl_MethodType fwdMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "forward",
+ InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
+};
+
+/*
+ * Helper macros (derived from things private to tclVar.c)
+ */
+
+#define TclVarTable(contextNs) \
+ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
+#define TclVarHashGetValue(hPtr) \
+ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewInstanceMethod --
+ *
+ * Attach a method to an object instance.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewInstanceMethod(
+ Tcl_Interp *interp, /* Unused? */
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Object *oPtr = (Object *) object;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ mPtr->refCount = 1;
+ goto populate;
+ }
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
+ if (isNew) {
+ mPtr = ckalloc(sizeof(Method));
+ mPtr->namePtr = nameObj;
+ mPtr->refCount = 1;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = oPtr;
+ mPtr->declaringClassPtr = NULL;
+ if (flags) {
+ mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ }
+ oPtr->epoch++;
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewMethod --
+ *
+ * Attach a method to a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Class *clsPtr = (Class *) cls;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ mPtr->refCount = 1;
+ goto populate;
+ }
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
+ if (isNew) {
+ mPtr = ckalloc(sizeof(Method));
+ mPtr->refCount = 1;
+ mPtr->namePtr = nameObj;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ clsPtr->thisPtr->fPtr->epoch++;
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = NULL;
+ mPtr->declaringClassPtr = clsPtr;
+ if (flags) {
+ mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ }
+
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODelMethodRef --
+ *
+ * How to delete a method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODelMethodRef(
+ Method *mPtr)
+{
+ if ((mPtr != NULL) && (--mPtr->refCount <= 0)) {
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ if (mPtr->namePtr != NULL) {
+ Tcl_DecrRefCount(mPtr->namePtr);
+ }
+
+ ckfree(mPtr);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewBasicMethod --
+ *
+ * Helper that makes it cleaner to create very simple methods during
+ * basic system initialization. Not suitable for general use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOONewBasicMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr, /* Class to attach the method to. */
+ const DeclaredClassMethod *dcm)
+ /* Name of the method, whether it is public,
+ * and the function to implement it. */
+{
+ Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
+
+ Tcl_IncrRefCount(namePtr);
+ Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
+ Tcl_DecrRefCount(namePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcInstanceMethod --
+ *
+ * Create a new procedure-like method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcInstanceMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which must not be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which must not be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
+ * structure to allow for deeper tuning of the
+ * structure's contents. NULL if caller is not
+ * interested. */
+{
+ int argsLen;
+ register ProcedureMethod *pmPtr;
+ Tcl_Method method;
+
+ if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ return NULL;
+ }
+ pmPtr = ckalloc(sizeof(ProcedureMethod));
+ memset(pmPtr, 0, sizeof(ProcedureMethod));
+ pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->refCount = 1;
+
+ method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
+ argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
+ if (method == NULL) {
+ ckfree(pmPtr);
+ } else if (pmPtrPtr != NULL) {
+ *pmPtrPtr = pmPtr;
+ }
+ return (Method *) method;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcMethod --
+ *
+ * Create a new procedure-like method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Class *clsPtr, /* The class to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which may be NULL; if so, it is equivalent
+ * to an empty list. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
+ * structure to allow for deeper tuning of the
+ * structure's contents. NULL if caller is not
+ * interested. */
+{
+ int argsLen; /* -1 => delete argsObj before exit */
+ register ProcedureMethod *pmPtr;
+ const char *procName;
+ Tcl_Method method;
+
+ if (argsObj == NULL) {
+ argsLen = -1;
+ argsObj = Tcl_NewObj();
+ Tcl_IncrRefCount(argsObj);
+ procName = "<destructor>";
+ } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ return NULL;
+ } else {
+ procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
+ }
+
+ pmPtr = ckalloc(sizeof(ProcedureMethod));
+ memset(pmPtr, 0, sizeof(ProcedureMethod));
+ pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->refCount = 1;
+
+ method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
+ argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
+
+ if (argsLen == -1) {
+ Tcl_DecrRefCount(argsObj);
+ }
+ if (method == NULL) {
+ ckfree(pmPtr);
+ } else if (pmPtrPtr != NULL) {
+ *pmPtrPtr = pmPtr;
+ }
+
+ return (Method *) method;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOMakeProcInstanceMethod --
+ *
+ * The guts of the code to make a procedure-like method for an object.
+ * Split apart so that it is easier for other extensions to reuse (in
+ * particular, it frees them from having to pry so deeply into Tcl's
+ * guts).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+TclOOMakeProcInstanceMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which _must not_ be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
+ * NULL. */
+ const Tcl_MethodType *typePtr,
+ /* The type of the method to create. */
+ ClientData clientData, /* The per-method type-specific data. */
+ Proc **procPtrPtr) /* A pointer to the variable in which to write
+ * the procedure record reference. Presumably
+ * inside the structure indicated by the
+ * pointer in clientData. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr;
+
+ if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
+ procPtrPtr) != TCL_OK) {
+ return NULL;
+ }
+ procPtr = *procPtrPtr;
+ procPtr->cmdPtr = NULL;
+
+ if (iPtr->cmdFramePtr) {
+ CmdFrame context = *iPtr->cmdFramePtr;
+
+ if (context.type == TCL_LOCATION_BC) {
+ /*
+ * Retrieve source information from the bytecode, if possible. If
+ * the information is retrieved successfully, context.type will be
+ * TCL_LOCATION_SOURCE and the reference held by
+ * context.data.eval.path will be counted.
+ */
+
+ TclGetSrcInfoForPc(&context);
+ } else if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * The copy into 'context' up above has created another reference
+ * to 'context.data.eval.path'; account for it.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
+ }
+
+ if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * We can account for source location within a proc only if the
+ * proc body was not created by substitution.
+ * (FIXME: check that this is sane and correct!)
+ */
+
+ if (context.line
+ && (context.nline >= 4) && (context.line[3] >= 0)) {
+ int isNew;
+ CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = ckalloc(sizeof(int));
+ cfPtr->line[0] = context.line[3];
+ cfPtr->nline = 1;
+ cfPtr->framePtr = NULL;
+ cfPtr->nextPtr = NULL;
+
+ cfPtr->data.eval.path = context.data.eval.path;
+ Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+ cfPtr->cmd.str.cmd = NULL;
+ cfPtr->cmd.str.len = 0;
+
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+ (char *) procPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cfPtr);
+ }
+
+ /*
+ * 'context' is going out of scope; account for the reference that
+ * it's holding to the path name.
+ */
+
+ Tcl_DecrRefCount(context.data.eval.path);
+ context.data.eval.path = NULL;
+ }
+ }
+
+ return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ typePtr, clientData);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOMakeProcMethod --
+ *
+ * The guts of the code to make a procedure-like method for a class.
+ * Split apart so that it is easier for other extensions to reuse (in
+ * particular, it frees them from having to pry so deeply into Tcl's
+ * guts).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+TclOOMakeProcMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Class *clsPtr, /* The class to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ const char *namePtr, /* The name of the method as a string, which
+ * _must not_ be NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which _must not_ be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
+ * NULL. */
+ const Tcl_MethodType *typePtr,
+ /* The type of the method to create. */
+ ClientData clientData, /* The per-method type-specific data. */
+ Proc **procPtrPtr) /* A pointer to the variable in which to write
+ * the procedure record reference. Presumably
+ * inside the structure indicated by the
+ * pointer in clientData. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr;
+
+ if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
+ procPtrPtr) != TCL_OK) {
+ return NULL;
+ }
+ procPtr = *procPtrPtr;
+ procPtr->cmdPtr = NULL;
+
+ if (iPtr->cmdFramePtr) {
+ CmdFrame context = *iPtr->cmdFramePtr;
+
+ if (context.type == TCL_LOCATION_BC) {
+ /*
+ * Retrieve source information from the bytecode, if possible. If
+ * the information is retrieved successfully, context.type will be
+ * TCL_LOCATION_SOURCE and the reference held by
+ * context.data.eval.path will be counted.
+ */
+
+ TclGetSrcInfoForPc(&context);
+ } else if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * The copy into 'context' up above has created another reference
+ * to 'context.data.eval.path'; account for it.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
+ }
+
+ if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * We can account for source location within a proc only if the
+ * proc body was not created by substitution.
+ * (FIXME: check that this is sane and correct!)
+ */
+
+ if (context.line
+ && (context.nline >= 4) && (context.line[3] >= 0)) {
+ int isNew;
+ CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = ckalloc(sizeof(int));
+ cfPtr->line[0] = context.line[3];
+ cfPtr->nline = 1;
+ cfPtr->framePtr = NULL;
+ cfPtr->nextPtr = NULL;
+
+ cfPtr->data.eval.path = context.data.eval.path;
+ Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+ cfPtr->cmd.str.cmd = NULL;
+ cfPtr->cmd.str.len = 0;
+
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+ (char *) procPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cfPtr);
+ }
+
+ /*
+ * 'context' is going out of scope; account for the reference that
+ * it's holding to the path name.
+ */
+
+ Tcl_DecrRefCount(context.data.eval.path);
+ context.data.eval.path = NULL;
+ }
+ }
+
+ return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ clientData);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeProcedureMethod, PushMethodCallFrame --
+ *
+ * How to invoke a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeProcedureMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ ProcedureMethod *pmPtr = clientData;
+ int result;
+ PMFrameData *fdPtr; /* Important data that has to have a lifetime
+ * matched by this function (or rather, by the
+ * call frame's lifetime). */
+
+ /*
+ * If the interpreter was deleted, we just skip to the next thing in the
+ * chain.
+ */
+
+ if (Tcl_InterpDeleted(interp)) {
+ return TclNRObjectContextInvokeNext(interp, context, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context));
+ }
+
+ /*
+ * Allocate the special frame data.
+ */
+
+ fdPtr = TclStackAlloc(interp, sizeof(PMFrameData));
+
+ /*
+ * Create a call frame for this method.
+ */
+
+ result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
+ objc, objv, fdPtr);
+ if (result != TCL_OK) {
+ TclStackFree(interp, fdPtr);
+ return result;
+ }
+ pmPtr->refCount++;
+
+ /*
+ * Give the pre-call callback a chance to do some setup and, possibly,
+ * veto the call.
+ */
+
+ if (pmPtr->preCallProc != NULL) {
+ int isFinished;
+
+ result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
+ (Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
+ if (isFinished || result != TCL_OK) {
+ /*
+ * Restore the old cmdPtr so that a subsequent use of [info frame]
+ * won't crash on us. [Bug 3001438]
+ */
+
+ pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+
+ Tcl_PopCallFrame(interp);
+ TclStackFree(interp, fdPtr->framePtr);
+ if (--pmPtr->refCount < 1) {
+ DeleteProcedureMethodRecord(pmPtr);
+ }
+ TclStackFree(interp, fdPtr);
+ return result;
+ }
+ }
+
+ /*
+ * Now invoke the body of the method.
+ */
+
+ TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
+ return TclNRInterpProcCore(interp, fdPtr->nameObj,
+ Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
+}
+
+static int
+FinalizePMCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ProcedureMethod *pmPtr = data[0];
+ Tcl_ObjectContext context = data[1];
+ PMFrameData *fdPtr = data[2];
+
+ /*
+ * Give the post-call callback a chance to do some cleanup. Note that at
+ * this point the call frame itself is invalid; it's already been popped.
+ */
+
+ if (pmPtr->postCallProc) {
+ result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
+ result);
+ }
+
+ /*
+ * Restore the old cmdPtr so that a subsequent use of [info frame] won't
+ * crash on us. [Bug 3001438]
+ */
+
+ pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+
+ /*
+ * Scrap the special frame data now that we're done with it. Note that we
+ * are inlining DeleteProcedureMethod() here; this location is highly
+ * sensitive when it comes to performance!
+ */
+
+ if (--pmPtr->refCount < 1) {
+ DeleteProcedureMethodRecord(pmPtr);
+ }
+ TclStackFree(interp, fdPtr);
+ return result;
+}
+
+static int
+PushMethodCallFrame(
+ Tcl_Interp *interp, /* Current interpreter. */
+ CallContext *contextPtr, /* Current method call context. */
+ ProcedureMethod *pmPtr, /* Information about this procedure-like
+ * method. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv, /* Array of arguments. */
+ PMFrameData *fdPtr) /* Place to store information about the call
+ * frame. */
+{
+ Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
+ register int result;
+ const char *namePtr;
+ CallFrame **framePtrPtr = &fdPtr->framePtr;
+
+ /*
+ * Compute basic information on the basis of the type of method it is.
+ */
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ namePtr = "<constructor>";
+ fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
+ fdPtr->errProc = ConstructorErrorHandler;
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ namePtr = "<destructor>";
+ fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
+ fdPtr->errProc = DestructorErrorHandler;
+ } else {
+ fdPtr->nameObj = Tcl_MethodName(
+ Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
+ namePtr = TclGetString(fdPtr->nameObj);
+ fdPtr->errProc = MethodErrorHandler;
+ }
+ if (pmPtr->errProc != NULL) {
+ fdPtr->errProc = pmPtr->errProc;
+ }
+
+ /*
+ * Magic to enable things like [incr Tcl], which wants methods to run in
+ * their class's namespace.
+ */
+
+ if (pmPtr->flags & USE_DECLARER_NS) {
+ register Method *mPtr =
+ contextPtr->callPtr->chain[contextPtr->index].mPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ nsPtr = (Namespace *)
+ mPtr->declaringClassPtr->thisPtr->namespacePtr;
+ } else {
+ nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
+ }
+ }
+
+ /*
+ * Save the old cmdPtr so that when this recursive call returns, we can
+ * restore it. To do otherwise causes crashes in [info frame] after we
+ * return from a recursive call. [Bug 3001438]
+ */
+
+ fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr;
+
+ /*
+ * Compile the body. This operation may fail.
+ */
+
+ fdPtr->efi.length = 2;
+ memset(&fdPtr->cmd, 0, sizeof(Command));
+ fdPtr->cmd.nsPtr = nsPtr;
+ fdPtr->cmd.clientData = &fdPtr->efi;
+ pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
+
+ /*
+ * [Bug 2037727] Always call TclProcCompileProc so that we check not only
+ * that we have bytecode, but also that it remains valid. Note that we set
+ * the namespace of the code here directly; this is a hack, but the
+ * alternative is *so* slow...
+ */
+
+ if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCode *codePtr =
+ pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+
+ codePtr->nsPtr = nsPtr;
+ }
+ result = TclProcCompileProc(interp, pmPtr->procPtr,
+ pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr);
+ if (result != TCL_OK) {
+ goto failureReturn;
+ }
+
+ /*
+ * Make the stack frame and fill it out with information about this call.
+ * This operation may fail.
+ */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD);
+ if (result != TCL_OK) {
+ goto failureReturn;
+ }
+
+ fdPtr->framePtr->clientData = contextPtr;
+ fdPtr->framePtr->objc = objc;
+ fdPtr->framePtr->objv = objv;
+ fdPtr->framePtr->procPtr = pmPtr->procPtr;
+
+ /*
+ * Finish filling out the extra frame info so that [info frame] works.
+ */
+
+ fdPtr->efi.fields[0].name = "method";
+ fdPtr->efi.fields[0].proc = NULL;
+ fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
+ if (pmPtr->gfivProc != NULL) {
+ fdPtr->efi.fields[1].name = "";
+ fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
+ fdPtr->efi.fields[1].clientData = pmPtr;
+ } else {
+ register Tcl_Method method =
+ Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
+
+ if (Tcl_MethodDeclarerObject(method) != NULL) {
+ fdPtr->efi.fields[1].name = "object";
+ } else {
+ fdPtr->efi.fields[1].name = "class";
+ }
+ fdPtr->efi.fields[1].proc = RenderDeclarerName;
+ fdPtr->efi.fields[1].clientData = &fdPtr->pni;
+ fdPtr->pni.interp = interp;
+ fdPtr->pni.method = method;
+ }
+
+ return TCL_OK;
+
+ /*
+ * Restore the old cmdPtr so that a subsequent use of [info frame] won't
+ * crash on us. [Bug 3001438]
+ */
+
+ failureReturn:
+ pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOSetupVariableResolver, etc. --
+ *
+ * Variable resolution engine used to connect declared variables to local
+ * variables used in methods. The compiled variable resolver is more
+ * important, but both are needed as it is possible to have a variable
+ * that is only referred to in ways that aren't compilable and we can't
+ * force LVT presence. [TIP #320]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOSetupVariableResolver(
+ Tcl_Namespace *nsPtr)
+{
+ Tcl_ResolverInfo info;
+
+ Tcl_GetNamespaceResolvers(nsPtr, &info);
+ if (info.compiledVarResProc == NULL) {
+ Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
+ ProcedureMethodCompiledVarResolver);
+ }
+}
+
+static int
+ProcedureMethodVarResolver(
+ Tcl_Interp *interp,
+ const char *varName,
+ Tcl_Namespace *contextNs,
+ int flags,
+ Tcl_Var *varPtr)
+{
+ int result;
+ Tcl_ResolvedVarInfo *rPtr = NULL;
+
+ result = ProcedureMethodCompiledVarResolver(interp, varName,
+ strlen(varName), contextNs, &rPtr);
+
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ *varPtr = rPtr->fetchProc(interp, rPtr);
+
+ /*
+ * Must not retain reference to resolved information. [Bug 3105999]
+ */
+
+ if (rPtr != NULL) {
+ rPtr->deleteProc(rPtr);
+ }
+ return (*varPtr? TCL_OK : TCL_CONTINUE);
+}
+
+static Tcl_Var
+ProcedureMethodCompiledVarConnect(
+ Tcl_Interp *interp,
+ Tcl_ResolvedVarInfo *rPtr)
+{
+ OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Tcl_Obj *variableObj;
+ Tcl_HashEntry *hPtr;
+ int i, isNew, cacheIt, varLen, len;
+ const char *match, *varName;
+
+ /*
+ * Check that the variable is being requested in a context that is also a
+ * method call; if not (i.e. we're evaluating in the object's namespace or
+ * in a procedure of that namespace) then we do nothing.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ return NULL;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * If we've done the work before (in a comparable context) then reuse that
+ * rather than performing resolution ourselves.
+ */
+
+ if (infoPtr->cachedObjectVar) {
+ return infoPtr->cachedObjectVar;
+ }
+
+ /*
+ * Check if the variable is one we want to resolve at all (i.e. whether it
+ * is in the list provided by the user). If not, we mustn't do anything
+ * either.
+ */
+
+ varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
+ if (contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr != NULL) {
+ FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->variables) {
+ match = TclGetStringFromObj(variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ cacheIt = 0;
+ goto gotMatch;
+ }
+ }
+ } else {
+ FOREACH(variableObj, contextPtr->oPtr->variables) {
+ match = TclGetStringFromObj(variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ cacheIt = 1;
+ goto gotMatch;
+ }
+ }
+ }
+ return NULL;
+
+ /*
+ * It is a variable we want to resolve, so resolve it.
+ */
+
+ gotMatch:
+ hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
+ (char *) variableObj, &isNew);
+ if (isNew) {
+ TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
+ }
+ if (cacheIt) {
+ infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
+
+ /*
+ * We must keep a reference to the variable so everything will
+ * continue to work correctly even if it is unset; being unset does
+ * not end the life of the variable at this level. [Bug 3185009]
+ */
+
+ VarHashRefCount(infoPtr->cachedObjectVar)++;
+ }
+ return TclVarHashGetValue(hPtr);
+}
+
+static void
+ProcedureMethodCompiledVarDelete(
+ Tcl_ResolvedVarInfo *rPtr)
+{
+ OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
+
+ /*
+ * Release the reference to the variable if we were holding it.
+ */
+
+ if (infoPtr->cachedObjectVar) {
+ VarHashRefCount(infoPtr->cachedObjectVar)--;
+ TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
+ }
+ Tcl_DecrRefCount(infoPtr->variableObj);
+ ckfree(infoPtr);
+}
+
+static int
+ProcedureMethodCompiledVarResolver(
+ Tcl_Interp *interp,
+ const char *varName,
+ int length,
+ Tcl_Namespace *contextNs,
+ Tcl_ResolvedVarInfo **rPtrPtr)
+{
+ OOResVarInfo *infoPtr;
+ Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
+
+ /*
+ * Do not create resolvers for cases that contain namespace separators or
+ * which look like array accesses. Both will lead us astray.
+ */
+
+ if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
+ Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
+ Tcl_DecrRefCount(variableObj);
+ return TCL_CONTINUE;
+ }
+
+ infoPtr = ckalloc(sizeof(OOResVarInfo));
+ infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
+ infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
+ infoPtr->cachedObjectVar = NULL;
+ infoPtr->variableObj = variableObj;
+ Tcl_IncrRefCount(variableObj);
+ *rPtrPtr = &infoPtr->info;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RenderDeclarerName --
+ *
+ * Returns the name of the entity (object or class) which declared a
+ * method. Used for producing information for [info frame] in such a way
+ * that the expensive part of this (generating the object or class name
+ * itself) isn't done until it is needed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+RenderDeclarerName(
+ ClientData clientData)
+{
+ struct PNI *pni = clientData;
+ Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
+
+ if (object == NULL) {
+ object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
+ }
+ return TclOOObjectName(pni->interp, (Object *) object);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
+ *
+ * How to fill in the stack trace correctly upon error in various forms
+ * of procedure-like methods. LIMIT is how long the inserted strings in
+ * the error traces should get before being converted to have ellipses,
+ * and ELLIPSIFY is a macro to do the conversion (with the help of a
+ * %.*s%s format field). Note that ELLIPSIFY is only safe for use in
+ * suitable formatting contexts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+#define LIMIT 60
+#define ELLIPSIFY(str,len) \
+ ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
+
+static void
+MethodErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ int nameLen, objectNameLen;
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ const char *objectName, *kindName, *methodName =
+ Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
+ Object *declarerPtr;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
+ kindName, ELLIPSIFY(objectName, objectNameLen),
+ ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
+}
+
+static void
+ConstructorErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Object *declarerPtr;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) {
+ /*
+ * Horrible hack to deal with certain constructors that must not add
+ * information to the error trace.
+ */
+
+ return;
+ }
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" constructor line %d)", kindName,
+ ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
+}
+
+static void
+DestructorErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Object *declarerPtr;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" destructor line %d)", kindName,
+ ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteProcedureMethod, CloneProcedureMethod --
+ *
+ * How to delete and clone procedure-like methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteProcedureMethodRecord(
+ ProcedureMethod *pmPtr)
+{
+ TclProcDeleteProc(pmPtr->procPtr);
+ if (pmPtr->deleteClientdataProc) {
+ pmPtr->deleteClientdataProc(pmPtr->clientData);
+ }
+ ckfree(pmPtr);
+}
+
+static void
+DeleteProcedureMethod(
+ ClientData clientData)
+{
+ register ProcedureMethod *pmPtr = clientData;
+
+ if (--pmPtr->refCount < 1) {
+ DeleteProcedureMethodRecord(pmPtr);
+ }
+}
+
+static int
+CloneProcedureMethod(
+ Tcl_Interp *interp,
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ProcedureMethod *pmPtr = clientData;
+ ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod));
+
+ memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
+ pm2Ptr->refCount = 1;
+ pm2Ptr->procPtr->refCount++;
+ if (pmPtr->cloneClientdataProc) {
+ pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
+ }
+ *newClientData = pm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ * Create a forwarded method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardInstanceMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Object *oPtr, /* The object to attach the method to. */
+ int flags, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+ Tcl_Obj *cmdObj;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
+ return NULL;
+ }
+
+ 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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ * Create a new forwarded method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Class *clsPtr, /* The class to attach the method to. */
+ int flags, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+ Tcl_Obj *cmdObj;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
+ return NULL;
+ }
+
+ 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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeForwardMethod --
+ *
+ * How to invoke a forwarded method. Works by doing some ensemble-like
+ * command rearranging and then invokes some other Tcl command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeForwardMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ 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
+ * prefixObj field of the ForwardMethod structure holds a reference to a
+ * non-empty list, so there's a whole class of failures ("not a list") we
+ * can ignore here.
+ */
+
+ 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);
+}
+
+static int
+FinalizeForwardCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **argObjs = data[0];
+
+ TclStackFree(interp, argObjs);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteForwardMethod, CloneForwardMethod --
+ *
+ * How to delete and clone forwarded methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteForwardMethod(
+ ClientData clientData)
+{
+ ForwardMethod *fmPtr = clientData;
+
+ Tcl_DecrRefCount(fmPtr->prefixObj);
+ ckfree(fmPtr);
+}
+
+static int
+CloneForwardMethod(
+ Tcl_Interp *interp,
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ForwardMethod *fmPtr = clientData;
+ ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
+
+ fm2Ptr->prefixObj = fmPtr->prefixObj;
+ fm2Ptr->fullyQualified = fmPtr->fullyQualified;
+ Tcl_IncrRefCount(fm2Ptr->prefixObj);
+ *newClientData = fm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
+ *
+ * Utility functions used for procedure-like and forwarding method
+ * introspection.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Proc *
+TclOOGetProcFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &procMethodType) {
+ ProcedureMethod *pmPtr = mPtr->clientData;
+
+ return pmPtr->procPtr;
+ }
+ return NULL;
+}
+
+Tcl_Obj *
+TclOOGetMethodBody(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &procMethodType) {
+ ProcedureMethod *pmPtr = mPtr->clientData;
+
+ if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
+ }
+ return pmPtr->procPtr->bodyPtr;
+ }
+ return NULL;
+}
+
+Tcl_Obj *
+TclOOGetFwdFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &fwdMethodType) {
+ ForwardMethod *fwPtr = mPtr->clientData;
+
+ return fwPtr->prefixObj;
+ }
+ return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitEnsembleRewrite --
+ *
+ * Utility function that wraps up a lot of the complexity involved in
+ * doing ensemble-like command forwarding. Here is a picture of memory
+ * management plan:
+ *
+ * <-----------------objc---------------------->
+ * objv: |=============|===============================|
+ * <-toRewrite-> |
+ * \
+ * <-rewriteLength-> \
+ * rewriteObjs: |=================| \
+ * | |
+ * V V
+ * argObjs: |=================|===============================|
+ * <------------------*lengthPtr------------------->
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj **
+InitEnsembleRewrite(
+ Tcl_Interp *interp, /* Place to log the rewrite info. */
+ int objc, /* Number of real arguments. */
+ Tcl_Obj *const *objv, /* The real arguments. */
+ int toRewrite, /* Number of real arguments to replace. */
+ int rewriteLength, /* Number of arguments to insert instead. */
+ Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
+ int *lengthPtr) /* Where to write the resulting length of the
+ * array of rewritten arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ Tcl_Obj **argObjs;
+ unsigned len = rewriteLength + objc - toRewrite;
+
+ argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
+ memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
+ memcpy(argObjs + rewriteLength, objv + toRewrite,
+ sizeof(Tcl_Obj *) * (objc - toRewrite));
+
+ /*
+ * Now plumb this into the core ensemble rewrite logging system so that
+ * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
+ * how to store the rewrite rules get complex solely because of the case
+ * where an ensemble rewrites itself out of the picture; when that
+ * happens, the quality of the error message rewrite falls drastically
+ * (and unavoidably).
+ */
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
+ iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+ } else {
+ int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+ if (numIns < toRewrite) {
+ iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;
+ iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs +=
+ rewriteLength - toRewrite;
+ }
+ }
+
+ *lengthPtr = len;
+ return argObjs;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * assorted trivial 'getter' functions
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_MethodDeclarerObject(
+ Tcl_Method method)
+{
+ return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
+}
+
+Tcl_Class
+Tcl_MethodDeclarerClass(
+ Tcl_Method method)
+{
+ return (Tcl_Class) ((Method *) method)->declaringClassPtr;
+}
+
+Tcl_Obj *
+Tcl_MethodName(
+ Tcl_Method method)
+{
+ return ((Method *) method)->namePtr;
+}
+
+int
+Tcl_MethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
+Tcl_MethodIsPublic(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
+}
+
+/*
+ * Extended method construction for itcl-ng.
+ */
+
+Tcl_Method
+TclOONewProcInstanceMethodEx(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Tcl_Object oPtr, /* The object to modify. */
+ TclOO_PreCallProc *preCallPtr,
+ TclOO_PostCallProc *postCallPtr,
+ ProcErrorProc *errProc,
+ ClientData clientData,
+ Tcl_Obj *nameObj, /* The name of the method, which must not be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which must not be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ int flags, /* Whether this is a public method. */
+ void **internalTokenPtr) /* If non-NULL, points to a variable that gets
+ * the reference to the ProcedureMethod
+ * structure. */
+{
+ ProcedureMethod *pmPtr;
+ Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp,
+ (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
+
+ if (method == NULL) {
+ return NULL;
+ }
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->preCallProc = preCallPtr;
+ pmPtr->postCallProc = postCallPtr;
+ pmPtr->errProc = errProc;
+ pmPtr->clientData = clientData;
+ if (internalTokenPtr != NULL) {
+ *internalTokenPtr = pmPtr;
+ }
+ return method;
+}
+
+Tcl_Method
+TclOONewProcMethodEx(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Tcl_Class clsPtr, /* The class to modify. */
+ TclOO_PreCallProc *preCallPtr,
+ TclOO_PostCallProc *postCallPtr,
+ ProcErrorProc *errProc,
+ ClientData clientData,
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which may be NULL; if so, it is equivalent
+ * to an empty list. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ int flags, /* Whether this is a public method. */
+ void **internalTokenPtr) /* If non-NULL, points to a variable that gets
+ * the reference to the ProcedureMethod
+ * structure. */
+{
+ ProcedureMethod *pmPtr;
+ Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp,
+ (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
+
+ if (method == NULL) {
+ return NULL;
+ }
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->preCallProc = preCallPtr;
+ pmPtr->postCallProc = postCallPtr;
+ pmPtr->errProc = errProc;
+ pmPtr->clientData = clientData;
+ if (internalTokenPtr != NULL) {
+ *internalTokenPtr = pmPtr;
+ }
+ return method;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
new file mode 100644
index 0000000..900ab22
--- /dev/null
+++ b/generic/tclOOStubInit.c
@@ -0,0 +1,78 @@
+/*
+ * This file is (mostly) automatically generated from tclOO.decls.
+ * It is compiled and linked in with the tclOO package proper.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclOOInt.h"
+
+MODULE_SCOPE const TclOOStubs tclOOStubs;
+
+#ifdef __GNUC__
+#pragma GCC dependency "tclOO.decls"
+#endif
+
+/* !BEGIN!: Do not edit below this line. */
+
+static const TclOOIntStubs tclOOIntStubs = {
+ TCL_STUB_MAGIC,
+ 0,
+ TclOOGetDefineCmdContext, /* 0 */
+ TclOOMakeProcInstanceMethod, /* 1 */
+ TclOOMakeProcMethod, /* 2 */
+ TclOONewProcInstanceMethod, /* 3 */
+ TclOONewProcMethod, /* 4 */
+ TclOOObjectCmdCore, /* 5 */
+ TclOOIsReachable, /* 6 */
+ TclOONewForwardMethod, /* 7 */
+ TclOONewForwardInstanceMethod, /* 8 */
+ TclOONewProcInstanceMethodEx, /* 9 */
+ TclOONewProcMethodEx, /* 10 */
+ TclOOInvokeObject, /* 11 */
+ TclOOObjectSetFilters, /* 12 */
+ TclOOClassSetFilters, /* 13 */
+ TclOOObjectSetMixins, /* 14 */
+ TclOOClassSetMixins, /* 15 */
+};
+
+static const TclOOStubHooks tclOOStubHooks = {
+ &tclOOIntStubs
+};
+
+const TclOOStubs tclOOStubs = {
+ TCL_STUB_MAGIC,
+ &tclOOStubHooks,
+ Tcl_CopyObjectInstance, /* 0 */
+ Tcl_GetClassAsObject, /* 1 */
+ Tcl_GetObjectAsClass, /* 2 */
+ Tcl_GetObjectCommand, /* 3 */
+ Tcl_GetObjectFromObj, /* 4 */
+ Tcl_GetObjectNamespace, /* 5 */
+ Tcl_MethodDeclarerClass, /* 6 */
+ Tcl_MethodDeclarerObject, /* 7 */
+ Tcl_MethodIsPublic, /* 8 */
+ Tcl_MethodIsType, /* 9 */
+ Tcl_MethodName, /* 10 */
+ Tcl_NewInstanceMethod, /* 11 */
+ Tcl_NewMethod, /* 12 */
+ Tcl_NewObjectInstance, /* 13 */
+ Tcl_ObjectDeleted, /* 14 */
+ Tcl_ObjectContextIsFiltering, /* 15 */
+ Tcl_ObjectContextMethod, /* 16 */
+ Tcl_ObjectContextObject, /* 17 */
+ Tcl_ObjectContextSkippedArgs, /* 18 */
+ Tcl_ClassGetMetadata, /* 19 */
+ Tcl_ClassSetMetadata, /* 20 */
+ Tcl_ObjectGetMetadata, /* 21 */
+ Tcl_ObjectSetMetadata, /* 22 */
+ Tcl_ObjectContextInvokeNext, /* 23 */
+ Tcl_ObjectGetMethodNameMapper, /* 24 */
+ Tcl_ObjectSetMethodNameMapper, /* 25 */
+ Tcl_ClassSetConstructor, /* 26 */
+ Tcl_ClassSetDestructor, /* 27 */
+ Tcl_GetObjectName, /* 28 */
+};
+
+/* !END!: Do not edit above this line. */
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
new file mode 100644
index 0000000..3b6ce37
--- /dev/null
+++ b/generic/tclOOStubLib.c
@@ -0,0 +1,84 @@
+/*
+ * 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;
+MODULE_SCOPE const TclOOIntStubs *tclOOIntStubsPtr;
+
+const TclOOStubs *tclOOStubsPtr = NULL;
+const TclOOIntStubs *tclOOIntStubsPtr = NULL;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclOOInitializeStubs --
+ * Load the tclOO package, initialize stub table pointer. Do not call
+ * this function directly, use Tcl_OOInitStubs() macro instead.
+ *
+ * Results:
+ * The actual version of the package that satisfies the request, or NULL
+ * to indicate that an error occurred.
+ *
+ * Side effects:
+ * Sets the stub table pointer.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE const char *
+TclOOInitializeStubs(
+ 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);
+
+ if (clientData == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "Error loading ", packageName, " package; ",
+ "package not present or incomplete", NULL);
+ return NULL;
+ } 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;
+ return actualVersion;
+
+ error:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "Error loading ", packageName, " package",
+ " (requested version '", version, "', loaded version '",
+ actualVersion, "'): ", errMsg, NULL);
+ return NULL;
+ }
+}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5c17df2..129d80d 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -16,7 +16,6 @@
#include "tclInt.h"
#include "tommath.h"
-#include <float.h>
#include <math.h>
/*
@@ -51,17 +50,17 @@ Tcl_Mutex tclObjMutex;
char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;
-
+
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
- * Structure for tracking the source file and line number where a given Tcl_Obj
- * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity
- * checking purposes.
+ * Structure for tracking the source file and line number where a given
+ * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
+ * for sanity checking purposes.
*/
typedef struct ObjData {
Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
- CONST char *file; /* The name of the source file calling this
+ const char *file; /* The name of the source file calling this
* function; used for debugging. */
int line; /* Line number in the source file; used for
* debugging. */
@@ -78,33 +77,29 @@ typedef struct ObjData {
*/
typedef struct ThreadSpecificData {
- Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj
- * generated by a call to the function
- * TclSubstTokens() from a literal text
- * where bs+nl sequences occured in it, if
- * any. I.e. this table keeps track of
- * invisible/stripped continuation lines. Its
- * keys are Tcl_Obj pointers, the values are
- * ContLineLoc pointers. See the file
- * tclCompile.h for the definition of this
- * structure, and for references to all related
- * places in the core.
- */
+ Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
+ * generated by a call to the function
+ * TclSubstTokens() from a literal text
+ * where bs+nl sequences occured in it, if
+ * any. I.e. this table keeps track of
+ * invisible and stripped continuation lines.
+ * Its keys are Tcl_Obj pointers, the values
+ * are ContLineLoc pointers. See the file
+ * tclCompile.h for the definition of this
+ * structure, and for references to all
+ * related places in the core. */
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
- /*
- * Thread local table that is used to check that a Tcl_Obj was not
- * allocated by some other thread.
- */
-
- Tcl_HashTable *objThreadMap;
+ Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
+ * that a Tcl_Obj was not allocated by some
+ * other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-static void ContLineLocFree (char* clientData);
-static void TclThreadFinalizeContLines (ClientData clientData);
-static ThreadSpecificData* TclGetContLineTable (void);
+static void ContLineLocFree(char *clientData);
+static void TclThreadFinalizeContLines(ClientData clientData);
+static ThreadSpecificData *TclGetContLineTable(void);
/*
* Nested Tcl_Obj deletion management support
@@ -153,11 +148,11 @@ typedef struct PendingObjData {
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
/* The string rep is already invalidated so we can use the bytes value \
- * for our pointer chain: push onto the head of the stack. */ \
- (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
+ * for our pointer chain: push onto the head of the stack. */ \
+ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
- (objPtrVar) = (contextPtr)->deletionStack; \
+ (objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
@@ -166,11 +161,15 @@ typedef struct PendingObjData {
#ifndef TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
- PendingObjData *CONST contextPtr = &pendingObjData
+ PendingObjData *const contextPtr = &pendingObjData
+#elif HAVE_FAST_TSD
+static __thread PendingObjData pendingObjData;
+#define ObjInitDeletionContext(contextPtr) \
+ PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
- PendingObjData *CONST contextPtr = (PendingObjData *) \
+ PendingObjData *const contextPtr = \
Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
@@ -179,27 +178,27 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
#define PACK_BIGNUM(bignum, objPtr) \
- if ((bignum).used > 0x7fff) { \
- mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
- *temp = bignum; \
- (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
+ if ((bignum).used > 0x7fff) { \
+ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
+ *temp = bignum; \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = temp; \
(objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \
- } else { \
- if ((bignum).alloc > 0x7fff) { \
- mp_shrink(&(bignum)); \
- } \
- (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
+ } else { \
+ if ((bignum).alloc > 0x7fff) { \
+ mp_shrink(&(bignum)); \
+ } \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void *) (bignum).dp; \
(objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
- | ((bignum).alloc << 15) | ((bignum).used)); \
+ | ((bignum).alloc << 15) | ((bignum).used)); \
}
#define UNPACK_BIGNUM(objPtr, bignum) \
if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \
(bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
- } else { \
- (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
+ } else { \
+ (bignum).dp = (objPtr)->internalRep.ptrAndLongRep.ptr; \
(bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
- (bignum).alloc = \
+ (bignum).alloc = \
((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
(bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
}
@@ -246,56 +245,56 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
-static Tcl_ObjType oldBooleanType = {
- "boolean", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+static const Tcl_ObjType oldBooleanType = {
+ "boolean", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetBooleanFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclBooleanType = {
- "booleanString", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+const Tcl_ObjType tclBooleanType = {
+ "booleanString", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetBooleanFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclDoubleType = {
- "double", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfDouble, /* updateStringProc */
- SetDoubleFromAny /* setFromAnyProc */
+const Tcl_ObjType tclDoubleType = {
+ "double", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfDouble, /* updateStringProc */
+ SetDoubleFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclIntType = {
- "int", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfInt, /* updateStringProc */
- SetIntFromAny /* setFromAnyProc */
+const Tcl_ObjType tclIntType = {
+ "int", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#ifndef NO_WIDE_TYPE
-Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+const Tcl_ObjType tclWideIntType = {
+ "wideInt", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfWideInt, /* updateStringProc */
+ SetWideIntFromAny /* setFromAnyProc */
};
#endif
-Tcl_ObjType tclBignumType = {
- "bignum", /* name */
- FreeBignum, /* freeIntRepProc */
- DupBignum, /* dupIntRepProc */
- UpdateStringOfBignum, /* updateStringProc */
- NULL /* setFromAnyProc */
+const Tcl_ObjType tclBignumType = {
+ "bignum", /* name */
+ FreeBignum, /* freeIntRepProc */
+ DupBignum, /* dupIntRepProc */
+ UpdateStringOfBignum, /* updateStringProc */
+ NULL /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
-Tcl_HashKeyType tclObjHashKeyType = {
+const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashObjKey, /* hashKeyProc */
@@ -317,14 +316,22 @@ Tcl_HashKeyType tclObjHashKeyType = {
* ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions
* use the second internal pointer field of the twoPtrValue field for their
* own purposes.
+ *
+ * TRICKY POINT! Some extensions update this structure! (Notably, these
+ * include TclBlend and TCom). This is highly ill-advised on their part, but
+ * does allow them to delete a command when references to it are gone, which
+ * is fragile but useful given their somewhat-OO style. Because of this, this
+ * structure MUST NOT be const so that the C compiler puts the data in
+ * writable memory. [Bug 2558422]
+ * TODO: Provide a better API for those extensions so that they can coexist...
*/
-static Tcl_ObjType tclCmdNameType = {
- "cmdName", /* name */
- FreeCmdNameInternalRep, /* freeIntRepProc */
- DupCmdNameInternalRep, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetCmdNameFromAny /* setFromAnyProc */
+Tcl_ObjType tclCmdNameType = {
+ "cmdName", /* name */
+ FreeCmdNameInternalRep, /* freeIntRepProc */
+ DupCmdNameInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetCmdNameFromAny /* setFromAnyProc */
};
/*
@@ -414,6 +421,7 @@ TclInitObjSubsystem(void)
tclObjsFreed = 0;
{
int i;
+
for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
tclObjsShared[i] = 0;
}
@@ -454,12 +462,12 @@ TclFinalizeThreadObjects(void)
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
- ckfree((char *) objData);
+ ckfree(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
- ckfree((char *) tablePtr);
+ ckfree(tablePtr);
tsdPtr->objThreadMap = NULL;
}
#endif
@@ -521,8 +529,8 @@ TclFinalizeObjects(void)
*----------------------------------------------------------------------
*/
-static ThreadSpecificData*
-TclGetContLineTable()
+static ThreadSpecificData *
+TclGetContLineTable(void)
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
@@ -533,10 +541,11 @@ TclGetContLineTable()
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
if (!tsdPtr->lineCLPtr) {
- tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
+ tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
- Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL);
+ Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
@@ -559,18 +568,17 @@ TclGetContLineTable()
*----------------------------------------------------------------------
*/
-ContLineLoc*
-TclContinuationsEnter(Tcl_Obj* objPtr,
- int num,
- int* loc)
+ContLineLoc *
+TclContinuationsEnter(
+ Tcl_Obj *objPtr,
+ int num,
+ int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr =
- Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);
-
- ContLineLoc* clLocPtr =
- (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));
+ Tcl_HashEntry *hPtr =
+ Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
+ ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
@@ -589,18 +597,18 @@ TclContinuationsEnter(Tcl_Obj* objPtr,
* incoming num/loc data even so. Because we are called from
* TclContinuationsEnterDerived for this case, which modified the
* stored locations (Rebased to the proper relative offset). Just
- * returning the stored entry and data would rebase them a second
- * time, or more, hosing the data. It is easier to simply replace, as
- * we are doing.
+ * returning the stored entry would rebase them a second time, or
+ * more, hosing the data. It is easier to simply replace, as we are
+ * doing.
*/
- ckfree((char *) Tcl_GetHashValue(hPtr));
+ ckfree(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
- memcpy (&clLocPtr->loc, loc, num*sizeof(int));
- clLocPtr->loc[num] = CLL_END; /* Sentinel */
- Tcl_SetHashValue (hPtr, clLocPtr);
+ memcpy(&clLocPtr->loc, loc, num*sizeof(int));
+ clLocPtr->loc[num] = CLL_END; /* Sentinel */
+ Tcl_SetHashValue(hPtr, clLocPtr);
return clLocPtr;
}
@@ -625,8 +633,14 @@ TclContinuationsEnter(Tcl_Obj* objPtr,
*/
void
-TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
+TclContinuationsEnterDerived(
+ Tcl_Obj *objPtr,
+ int start,
+ int *clNext)
{
+ int length, end, num;
+ int *wordCLLast = clNext;
+
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
@@ -647,20 +661,15 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
*/
/*
- * First compute the range of the word within the script.
+ * First compute the range of the word within the script. (Is there a
+ * better way which doesn't shimmer?)
*/
- int length, end, num;
- int* wordCLLast = clNext;
-
Tcl_GetStringFromObj(objPtr, &length);
- /* Is there a better way which doesn't shimmer ? */
-
- end = start + length; /* first char after the word */
+ end = start + length; /* First char after the word */
/*
- * Then compute the table slice covering the range of
- * the word.
+ * Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
@@ -668,21 +677,19 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
}
/*
- * And generate the table from the slice, if it was
- * not empty.
+ * And generate the table from the slice, if it was not empty.
*/
num = wordCLLast - clNext;
if (num) {
int i;
- ContLineLoc* clLocPtr =
- TclContinuationsEnter(objPtr, num, clNext);
+ ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);
/*
* Re-base the locations.
*/
- for (i=0;i<num;i++) {
+ for (i=0 ; i<num ; i++) {
clLocPtr->loc[i] -= start;
/*
@@ -704,9 +711,9 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
* TclContinuationsCopy --
*
* This procedure is a helper which copies the continuation line
- * information associated with a Tcl_Obj* to another Tcl_Obj*.
- * It is assumed that both contain the same string/script. Use
- * this when a script is duplicated because it was shared.
+ * information associated with a Tcl_Obj* to another Tcl_Obj*. It is
+ * assumed that both contain the same string/script. Use this when a
+ * script is duplicated because it was shared.
*
* Results:
* None.
@@ -719,13 +726,16 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
*/
void
-TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
+TclContinuationsCopy(
+ Tcl_Obj *objPtr,
+ Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr);
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
- ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr);
+ ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
@@ -740,8 +750,8 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
* information associated with a Tcl_Obj*, if it has any.
*
* Results:
- * A reference to the continuation line location table, or NULL
- * if the Tcl_Obj* has no such information associated with it.
+ * A reference to the continuation line location table, or NULL if the
+ * Tcl_Obj* has no such information associated with it.
*
* Side effects:
* None.
@@ -750,17 +760,18 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
*----------------------------------------------------------------------
*/
-ContLineLoc*
-TclContinuationsGet(Tcl_Obj* objPtr)
+ContLineLoc *
+TclContinuationsGet(
+ Tcl_Obj *objPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr);
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
- if (hPtr) {
- return (ContLineLoc*) Tcl_GetHashValue (hPtr);
- } else {
- return NULL;
+ if (!hPtr) {
+ return NULL;
}
+ return Tcl_GetHashValue(hPtr);
}
/*
@@ -782,7 +793,8 @@ TclContinuationsGet(Tcl_Obj* objPtr)
*/
static void
-TclThreadFinalizeContLines (ClientData clientData)
+TclThreadFinalizeContLines(
+ ClientData clientData)
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -793,19 +805,19 @@ TclThreadFinalizeContLines (ClientData clientData)
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&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));
- Tcl_DeleteHashEntry (hPtr);
+
+ ContLineLocFree(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
}
- Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
- ckfree((char *) tsdPtr->lineCLPtr);
+ Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
+ ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
@@ -827,9 +839,10 @@ TclThreadFinalizeContLines (ClientData clientData)
*/
static void
-ContLineLocFree (char* clientData)
+ContLineLocFree(
+ char *clientData)
{
- ckfree (clientData);
+ ckfree(clientData);
}
/*
@@ -853,7 +866,7 @@ ContLineLocFree (char* clientData)
void
Tcl_RegisterObjType(
- Tcl_ObjType *typePtr) /* Information about object type; storage must
+ const Tcl_ObjType *typePtr) /* Information about object type; storage must
* be statically allocated (must live
* forever). */
{
@@ -940,17 +953,17 @@ Tcl_AppendAllObjTypes(
*----------------------------------------------------------------------
*/
-Tcl_ObjType *
+const Tcl_ObjType *
Tcl_GetObjType(
- CONST char *typeName) /* Name of Tcl object type to look up. */
+ const char *typeName) /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
- Tcl_ObjType *typePtr = NULL;
+ const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
- typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
+ typePtr = Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
@@ -980,7 +993,7 @@ int
Tcl_ConvertToType(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object to convert. */
- Tcl_ObjType *typePtr) /* The target type. */
+ const Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
@@ -1070,7 +1083,7 @@ TclDbDumpActiveObjects(
void
TclDbInitNewObj(
register Tcl_Obj *objPtr,
- register CONST char *file, /* The name of the source file calling this
+ register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
@@ -1094,12 +1107,11 @@ TclDbInitNewObj(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
- tsdPtr->objThreadMap = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
+ tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
- hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew);
+ hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
@@ -1108,7 +1120,7 @@ TclDbInitNewObj(
* Record the debugging information.
*/
- objData = (ObjData *) ckalloc(sizeof(ObjData));
+ objData = ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
@@ -1200,7 +1212,7 @@ Tcl_NewObj(void)
Tcl_Obj *
Tcl_DbNewObj(
- register CONST char *file, /* The name of the source file calling this
+ register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
@@ -1218,7 +1230,7 @@ Tcl_DbNewObj(
Tcl_Obj *
Tcl_DbNewObj(
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1267,12 +1279,12 @@ TclAllocateFreeObjects(void)
* Purify apparently can't figure that out, and fires a false alarm.
*/
- basePtr = (char *) ckalloc(bytesToAlloc);
+ basePtr = ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
- objPtr->internalRep.otherValuePtr = (void *) prevPtr;
+ objPtr->internalRep.otherValuePtr = prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -1309,7 +1321,7 @@ void
TclFreeObj(
register Tcl_Obj *objPtr) /* The object to be freed. */
{
- register Tcl_ObjType *typePtr = objPtr->typePtr;
+ register const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
@@ -1321,10 +1333,12 @@ TclFreeObj(
Tcl_Panic("Reference count for %lx was negative", objPtr);
}
- /* Invalidate the string rep first so we can use the bytes value
- * for our pointer chain, and signal an obj deletion (as opposed
- * to shimmering) with 'length == -1' */
-
+ /*
+ * Invalidate the string rep first so we can use the bytes value for our
+ * pointer chain, and signal an obj deletion (as opposed to shimmering)
+ * with 'length == -1'.
+ */
+
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
@@ -1339,19 +1353,19 @@ TclFreeObj(
}
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objPtr);
+ ckfree(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
- PopObjToDelete(context,objToFree);
+ PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objToFree);
+ ckfree(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
@@ -1360,22 +1374,23 @@ TclFreeObj(
/*
* We cannot use TclGetContinuationTable() here, because that may
- * re-initialize the thread-data for calls coming after the
- * finalization. We have to access it using the low-level call and then
- * check for validity. This function can be called after
- * TclFinalizeThreadData() has already killed the thread-global data
- * structures. Performing TCL_TSD_INIT will leave us with an
- * un-initialized memory block upon which we crash (if we where to access
- * the uninitialized hashtable).
+ * re-initialize the thread-data for calls coming after the finalization.
+ * We have to access it using the low-level call and then check for
+ * validity. This function can be called after TclFinalizeThreadData() has
+ * already killed the thread-global data structures. Performing
+ * TCL_TSD_INIT will leave us with an un-initialized memory block upon
+ * which we crash (if we where to access the uninitialized hashtable).
*/
{
- ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashEntry *hPtr;
+
if (tsdPtr->lineCLPtr) {
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
@@ -1386,13 +1401,15 @@ void
TclFreeObj(
register Tcl_Obj *objPtr) /* The object to be freed. */
{
- /* Invalidate the string rep first so we can use the bytes value
- * for our pointer chain, and signal an obj deletion (as opposed
- * to shimmering) with 'length == -1' */
+ /*
+ * Invalidate the string rep first so we can use the bytes value for our
+ * pointer chain, and signal an obj deletion (as opposed to shimmering)
+ * with 'length == -1'.
+ */
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
-
+
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
* objPtr can be freed safely, as it will not attempt to free any
@@ -1432,7 +1449,8 @@ TclFreeObj(
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
- PopObjToDelete(context,objToFree);
+
+ PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
if ((objToFree->typePtr != NULL)
&& (objToFree->typePtr->freeIntRepProc != NULL)) {
@@ -1447,27 +1465,28 @@ TclFreeObj(
/*
* We cannot use TclGetContinuationTable() here, because that may
- * re-initialize the thread-data for calls coming after the
- * finalization. We have to access it using the low-level call and then
- * check for validity. This function can be called after
- * TclFinalizeThreadData() has already killed the thread-global data
- * structures. Performing TCL_TSD_INIT will leave us with an
- * un-initialized memory block upon which we crash (if we where to access
- * the uninitialized hashtable).
+ * re-initialize the thread-data for calls coming after the finalization.
+ * We have to access it using the low-level call and then check for
+ * validity. This function can be called after TclFinalizeThreadData() has
+ * already killed the thread-global data structures. Performing
+ * TCL_TSD_INIT will leave us with an un-initialized memory block upon
+ * which we crash (if we where to access the uninitialized hashtable).
*/
{
- ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashEntry *hPtr;
+
if (tsdPtr->lineCLPtr) {
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
}
-#endif
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -1493,7 +1512,6 @@ TclObjBeingDeleted(
{
return (objPtr->length == -1);
}
-
/*
*----------------------------------------------------------------------
@@ -1524,30 +1542,47 @@ TclObjBeingDeleted(
*----------------------------------------------------------------------
*/
+#define SetDuplicateObj(dupPtr, objPtr) \
+ { \
+ const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
+ const char *bytes = (objPtr)->bytes; \
+ if (bytes) { \
+ TclInitStringRep((dupPtr), bytes, (objPtr)->length); \
+ } else { \
+ (dupPtr)->bytes = NULL; \
+ } \
+ if (typePtr) { \
+ if (typePtr->dupIntRepProc) { \
+ typePtr->dupIntRepProc((objPtr), (dupPtr)); \
+ } else { \
+ (dupPtr)->internalRep = (objPtr)->internalRep; \
+ (dupPtr)->typePtr = typePtr; \
+ } \
+ } \
+ }
+
Tcl_Obj *
Tcl_DuplicateObj(
- register Tcl_Obj *objPtr) /* The object to duplicate. */
+ Tcl_Obj *objPtr) /* The object to duplicate. */
{
- register Tcl_ObjType *typePtr = objPtr->typePtr;
- register Tcl_Obj *dupPtr;
+ Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
+ SetDuplicateObj(dupPtr, objPtr);
+ return dupPtr;
+}
- if (objPtr->bytes == NULL) {
- dupPtr->bytes = NULL;
- } else if (objPtr->bytes != tclEmptyStringRep) {
- TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
- }
-
- if (typePtr != NULL) {
- if (typePtr->dupIntRepProc == NULL) {
- dupPtr->internalRep = objPtr->internalRep;
- dupPtr->typePtr = typePtr;
- } else {
- (*typePtr->dupIntRepProc)(objPtr, dupPtr);
- }
+void
+TclSetDuplicateObj(
+ Tcl_Obj *dupPtr,
+ Tcl_Obj *objPtr)
+{
+ if (Tcl_IsShared(dupPtr)) {
+ Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
- return dupPtr;
+ TclInvalidateStringRep(dupPtr);
+ TclFreeIntRep(dupPtr);
+ SetDuplicateObj(dupPtr, objPtr);
}
/*
@@ -1580,11 +1615,29 @@ Tcl_GetString(
return objPtr->bytes;
}
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant of
+ * a properly maintained Tcl_Obj is that at least one of objPtr->bytes
+ * and objPtr->typePtr must not be NULL. If broken extensions fail to
+ * maintain that invariant, we can crash here.
+ */
+
if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an updateStringProc
+ * must be written in such a way that (objPtr->bytes) never becomes
+ * NULL. This panic was added in Tcl 8.1.
+ */
+
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
- (*objPtr->typePtr->updateStringProc)(objPtr);
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep", objPtr->typePtr->name);
+ }
return objPtr->bytes;
}
@@ -1619,13 +1672,7 @@ Tcl_GetStringFromObj(
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- if (objPtr->bytes == NULL) {
- if (objPtr->typePtr->updateStringProc == NULL) {
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- (*objPtr->typePtr->updateStringProc)(objPtr);
- }
+ (void) TclGetString(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
@@ -1658,7 +1705,6 @@ Tcl_InvalidateStringRep(
{
TclInvalidateStringRep(objPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -1737,7 +1783,7 @@ Tcl_NewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
register int boolValue, /* Boolean used to initialize new object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1757,7 +1803,7 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
register int boolValue, /* Boolean used to initialize new object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1817,7 +1863,7 @@ Tcl_SetBooleanObj(
int
Tcl_GetBooleanFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get boolean. */
register int *boolPtr) /* Place to store resulting boolean. */
{
@@ -1839,7 +1885,7 @@ Tcl_GetBooleanFromObj(
* sets the proper error message for us.
*/
- double d;
+ double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
@@ -1924,13 +1970,14 @@ SetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
- char *str = Tcl_GetStringFromObj(objPtr, &length);
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
}
return TCL_ERROR;
}
@@ -1940,10 +1987,14 @@ ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int i, length, newBool;
- char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length);
+ char lowerCase[6];
+ const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
- /* longest valid boolean string rep. is "false" */
+ /*
+ * Longest valid boolean string rep. is "false".
+ */
+
return TCL_ERROR;
}
@@ -1969,6 +2020,7 @@ ParseBoolean(
for (i=0; i < length; i++) {
char c = str[i];
+
switch (c) {
case 'A': case 'E': case 'F': case 'L': case 'N':
case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y':
@@ -2122,7 +2174,7 @@ Tcl_NewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
register double dblValue, /* Double used to initialize the object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2142,7 +2194,7 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
register double dblValue, /* Double used to initialize the object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2203,7 +2255,7 @@ Tcl_SetDoubleObj(
int
Tcl_GetDoubleFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a double. */
register double *dblPtr) /* Place to store resulting double. */
{
@@ -2213,6 +2265,8 @@ Tcl_GetDoubleFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
+ NULL);
}
return TCL_ERROR;
}
@@ -2225,8 +2279,9 @@ Tcl_GetDoubleFromObj(
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
- UNPACK_BIGNUM( objPtr, big );
- *dblPtr = TclBignumToDouble( &big );
+
+ UNPACK_BIGNUM(objPtr, big);
+ *dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
@@ -2299,8 +2354,8 @@ UpdateStringOfDouble(
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
len = strlen(buffer);
- objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
- strcpy(objPtr->bytes, buffer);
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
objPtr->length = len;
}
@@ -2415,7 +2470,7 @@ Tcl_SetIntObj(
int
Tcl_GetIntFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a int. */
register int *intPtr) /* Place to store resulting int. */
{
@@ -2429,7 +2484,7 @@ Tcl_GetIntFromObj(
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
if (interp != NULL) {
- CONST char *s =
+ const char *s =
"integer value too large to represent as non-long integer";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
@@ -2463,6 +2518,7 @@ SetIntFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
long l;
+
return TclGetLongFromObj(interp, objPtr, &l);
}
@@ -2494,8 +2550,8 @@ UpdateStringOfInt(
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
- objPtr->bytes = ckalloc((unsigned) len + 1);
- strcpy(objPtr->bytes, buffer);
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
objPtr->length = len;
}
@@ -2592,7 +2648,7 @@ Tcl_Obj *
Tcl_DbNewLongObj(
register long longValue, /* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2613,7 +2669,7 @@ Tcl_Obj *
Tcl_DbNewLongObj(
register long longValue, /* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2676,7 +2732,7 @@ Tcl_SetLongObj(
int
Tcl_GetLongFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a long. */
register long *longPtr) /* Place to store resulting long. */
{
@@ -2696,6 +2752,7 @@ Tcl_GetLongFromObj(
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
+
if (w >= -(Tcl_WideInt)(ULONG_MAX)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
@@ -2704,18 +2761,19 @@ Tcl_GetLongFromObj(
goto tooLarge;
}
#endif
- if (objPtr->typePtr == &tclDoubleType) {
- if (interp != NULL) {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected integer but got \"");
Tcl_AppendObjToObj(msg, objPtr);
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
@@ -2726,11 +2784,12 @@ Tcl_GetLongFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
/ DIGIT_BIT) {
unsigned long value = 0, numBytes = sizeof(long);
long scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
@@ -2747,7 +2806,7 @@ Tcl_GetLongFromObj(
tooLarge:
#endif
if (interp != NULL) {
- char *s = "integer value too large to represent";
+ const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
@@ -2797,7 +2856,7 @@ UpdateStringOfWideInt(
sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
len = strlen(buffer);
- objPtr->bytes = ckalloc((unsigned) len + 1);
+ objPtr->bytes = ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
@@ -2895,7 +2954,7 @@ Tcl_DbNewWideIntObj(
register Tcl_WideInt wideValue,
/* Wide integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2914,7 +2973,7 @@ Tcl_DbNewWideIntObj(
register Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2990,7 +3049,7 @@ Tcl_SetWideIntObj(
int
Tcl_GetWideIntFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
@@ -3006,18 +3065,19 @@ Tcl_GetWideIntFromObj(
*wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType) {
- if (interp != NULL) {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected integer but got \"");
Tcl_AppendObjToObj(msg, objPtr);
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
@@ -3026,7 +3086,7 @@ Tcl_GetWideIntFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideInt);
@@ -3046,8 +3106,8 @@ Tcl_GetWideIntFromObj(
}
}
if (interp != NULL) {
- char *s = "integer value too large to represent";
- Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
+ const char *s = "integer value too large to represent";
+ Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
@@ -3107,9 +3167,10 @@ FreeBignum(
UNPACK_BIGNUM(objPtr, toFree);
mp_clear(&toFree);
- if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) {
- ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
+ if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) {
+ ckfree(objPtr->internalRep.ptrAndLongRep.ptr);
}
+ objPtr->typePtr = NULL;
}
/*
@@ -3171,7 +3232,7 @@ UpdateStringOfBignum(
mp_int bignumVal;
int size;
int status;
- char* stringVal;
+ char *stringVal;
UNPACK_BIGNUM(objPtr, bignumVal);
status = mp_radix_size(&bignumVal, 10, &size);
@@ -3192,13 +3253,13 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = ckalloc((size_t) size);
+ stringVal = ckalloc(size);
status = mp_toradix_n(&bignumVal, stringVal, 10, size);
if (status != MP_OKAY) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
objPtr->bytes = stringVal;
- objPtr->length = size - 1; /* size includes a trailing null byte */
+ objPtr->length = size - 1; /* size includes a trailing NUL byte. */
}
/*
@@ -3231,7 +3292,7 @@ Tcl_Obj *
Tcl_NewBignumObj(
mp_int *bignumValue)
{
- Tcl_Obj* objPtr;
+ Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetBignumObj(objPtr, bignumValue);
@@ -3261,7 +3322,7 @@ Tcl_NewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
Tcl_Obj *objPtr;
@@ -3274,7 +3335,7 @@ Tcl_DbNewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
return Tcl_NewBignumObj(bignumValue);
@@ -3313,6 +3374,7 @@ GetBignumFromObj(
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
+
UNPACK_BIGNUM(objPtr, temp);
mp_init_copy(bignumValue, &temp);
} else {
@@ -3345,6 +3407,7 @@ GetBignumFromObj(
Tcl_AppendObjToObj(msg, objPtr);
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
@@ -3447,11 +3510,12 @@ Tcl_SetBignumObj(
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
- if ((size_t)(bignumValue->used)
+ if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
unsigned long value = 0, numBytes = sizeof(long);
long scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
goto tooLargeForLong;
}
@@ -3471,12 +3535,13 @@ Tcl_SetBignumObj(
}
tooLargeForLong:
#ifndef NO_WIDE_TYPE
- if ((size_t)(bignumValue->used)
+ if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideInt);
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *)&scratch;
+
if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
goto tooLargeForWide;
}
@@ -3501,6 +3566,24 @@ Tcl_SetBignumObj(
TclSetBignumIntRep(objPtr, bignumValue);
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetBignumIntRep --
+ *
+ * Install a bignum into the internal representation of an object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Object internal representation is updated and object type is set. The
+ * bignum value is cleared, since ownership has transferred to the
+ * object.
+ *
+ *----------------------------------------------------------------------
+ */
+
void
TclSetBignumIntRep(
Tcl_Obj *objPtr,
@@ -3511,8 +3594,9 @@ TclSetBignumIntRep(
/*
* Clear the mp_int value.
- * Don't call mp_clear() because it would free the digit array
- * we just packed into the Tcl_Obj.
+ *
+ * Don't call mp_clear() because it would free the digit array we just
+ * packed into the Tcl_Obj.
*/
bignumValue->dp = NULL;
@@ -3525,14 +3609,23 @@ TclSetBignumIntRep(
*
* TclGetNumberFromObj --
*
+ * Extracts a number (of any possible numeric type) from an object.
+ *
* Results:
+ * Whether the extraction worked. The type is stored in the variable
+ * referred to by the typePtr argument, and a pointer to the
+ * representation is stored in the variable referred to by the
+ * clientDataPtr.
*
* Side effects:
+ * Can allocate thread-specific data for handling the copy-out space for
+ * bignums; this space is shared within a thread.
*
*----------------------------------------------------------------------
*/
-int TclGetNumberFromObj(
+int
+TclGetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
ClientData *clientDataPtr,
@@ -3545,18 +3638,18 @@ int TclGetNumberFromObj(
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
- *clientDataPtr = &(objPtr->internalRep.doubleValue);
+ *clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_LONG;
- *clientDataPtr = &(objPtr->internalRep.longValue);
+ *clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
- *clientDataPtr = &(objPtr->internalRep.wideValue);
+ *clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
@@ -3564,7 +3657,8 @@ int TclGetNumberFromObj(
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
(int) sizeof(mp_int));
- UNPACK_BIGNUM( objPtr, *bigPtr );
+
+ UNPACK_BIGNUM(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
@@ -3599,7 +3693,7 @@ void
Tcl_DbIncrRefCount(
register Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3627,7 +3721,7 @@ Tcl_DbIncrRefCount(
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("%s%s",
"Trying to incr ref count of "
@@ -3664,7 +3758,7 @@ void
Tcl_DbDecrRefCount(
register Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3692,7 +3786,7 @@ Tcl_DbDecrRefCount(
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("%s%s",
"Trying to decr ref count of "
@@ -3707,7 +3801,7 @@ Tcl_DbDecrRefCount(
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
- ckfree((char *) objData);
+ ckfree(objData);
}
Tcl_DeleteHashEntry(hPtr);
@@ -3744,7 +3838,7 @@ Tcl_DbDecrRefCount(
int
Tcl_DbIsShared(
register Tcl_Obj *objPtr, /* The object to test for being shared. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3771,7 +3865,7 @@ Tcl_DbIsShared(
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("%s%s",
"Trying to check shared status of"
@@ -3845,11 +3939,10 @@ AllocObjEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
- Tcl_HashEntry *hPtr;
+ Tcl_Obj *objPtr = keyPtr;
+ Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry));
- hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
- hPtr->key.oneWordValue = (char *) objPtr;
+ hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
@@ -3878,9 +3971,9 @@ TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
- register CONST char *p1, *p2;
+ register const char *p1, *p2;
register int l1, l2;
/*
@@ -3942,7 +4035,7 @@ TclFreeObjEntry(
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
- ckfree((char *) hPtr);
+ ckfree(hPtr);
}
/*
@@ -3968,11 +4061,10 @@ TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
- CONST char *string = TclGetString(objPtr);
- int length = objPtr->length;
+ Tcl_Obj *objPtr = keyPtr;
+ int length;
+ const char *string = TclGetStringFromObj(objPtr, &length);
unsigned int result = 0;
- int i;
/*
* I tried a zillion different hash functions and asked many other people
@@ -3982,16 +4074,37 @@ TclHashObjKey(
* following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings, and
- * multiplying by 9 is just about as good.
+ * multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the hash value
- * for ever, plus they spread fairly rapidly up to the high-order bits
- * to fill out the hash value. This seems works well both for decimal
- * and *non-decimal strings.
+ * character's bits hang around in the low-order bits of the hash value
+ * for ever, plus they spread fairly rapidly up to the high-order bits
+ * to fill out the hash value. This seems works well both for decimal
+ * and non-decimal strings.
+ *
+ * Note that this function is very weak against malicious strings; it's
+ * very easy to generate multiple keys that have the same hashcode. On the
+ * other hand, that hardly ever actually occurs and this function *is*
+ * very cheap, even by comparison with industry-standard hashes like FNV.
+ * If real strength of hash is required though, use a custom hash based on
+ * Bob Jenkins's lookup3(), but be aware that it's significantly slower.
+ * Tcl does not use that level of strength because it typically does not
+ * need it (and some of the aspects of that strength are genuinely
+ * unnecessary given the rest of Tcl's hash machinery, and the fact that
+ * we do not either transfer hashes to another machine, use them as a true
+ * substitute for equality, or attempt to minimize work in rebuilding the
+ * hash table).
+ *
+ * See also HashStringKey in tclHash.c.
+ * See also HashString in tclLiteral.c.
+ *
+ * See [tcl-Feature Request #2958832]
*/
- for (i=0 ; i<length ; i++) {
- result += (result << 3) + string[i];
+ if (length > 0) {
+ result = UCHAR(*string);
+ while (--length) {
+ result += (result << 3) + UCHAR(*++string);
+ }
}
return result;
}
@@ -4026,9 +4139,6 @@ Tcl_GetCommandFromObj(
* global namespace. */
{
register ResolvedCmdName *resPtr;
- register Command *cmdPtr;
- Namespace *refNsPtr;
- int result;
/*
* Get the internal representation, converting to a command type if
@@ -4046,34 +4156,39 @@ Tcl_GetCommandFromObj(
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
- * to discard the old rep and create a new one.
+ * to discard the old rep and create a new one.
*/
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr != &tclCmdNameType)
- || (resPtr == NULL)
- || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch)
- || (cmdPtr->flags & CMD_IS_DELETED)
- || (interp != cmdPtr->nsPtr->interp)
- || (cmdPtr->nsPtr->flags & NS_DYING)
- || ((resPtr->refNsPtr != NULL) &&
- (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp))
- != resPtr->refNsPtr)
- || (resPtr->refNsId != refNsPtr->nsId)
- || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch)))
- ) {
-
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
-
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- if ((result == TCL_OK) && resPtr) {
- cmdPtr = resPtr->cmdPtr;
- } else {
- cmdPtr = NULL;
- }
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ register Command *cmdPtr = resPtr->cmdPtr;
+
+ if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
+ && !(cmdPtr->flags & CMD_IS_DELETED)
+ && (interp == cmdPtr->nsPtr->interp)
+ && !(cmdPtr->nsPtr->flags & NS_DYING)) {
+ register Namespace *refNsPtr = (Namespace *)
+ TclGetCurrentNamespace(interp);
+
+ if ((resPtr->refNsPtr == NULL)
+ || ((refNsPtr == resPtr->refNsPtr)
+ && (resPtr->refNsId == refNsPtr->nsId)
+ && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
+ return (Tcl_Command) cmdPtr;
+ }
+ }
}
-
- return (Tcl_Command) cmdPtr;
+
+ /*
+ * OK, must create a new internal representation (or fail) as any cache we
+ * had is invalid one way or another.
+ */
+
+ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
@@ -4091,7 +4206,7 @@ Tcl_GetCommandFromObj(
* The object's old internal rep is freed. It's string rep is not
* changed. The refcount in the Command structure is incremented to keep
* it from being freed if the command is later deleted until
- * TclExecuteByteCode has a chance to recognize that it was deleted.
+ * TclNRExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
@@ -4108,14 +4223,14 @@ TclSetCmdNameObj(
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Namespace *currNsPtr;
- char *name;
+ const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
return;
}
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
@@ -4124,7 +4239,7 @@ TclSetCmdNameObj(
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
- * NULL.
+ * NULL.
*/
resPtr->refNsPtr = NULL;
@@ -4134,14 +4249,14 @@ TclSetCmdNameObj(
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
-
+
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
@@ -4172,8 +4287,7 @@ FreeCmdNameInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
- register ResolvedCmdName *resPtr =
- (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
+ register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
@@ -4190,8 +4304,9 @@ FreeCmdNameInternalRep(
*/
Command *cmdPtr = resPtr->cmdPtr;
+
TclCleanupCommandMacro(cmdPtr);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
@@ -4222,10 +4337,9 @@ DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register ResolvedCmdName *resPtr = (ResolvedCmdName *)
- srcPtr->internalRep.twoPtrValue.ptr1;
+ register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
@@ -4260,7 +4374,7 @@ SetCmdNameFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
@@ -4278,7 +4392,8 @@ SetCmdNameFromAny(
*/
name = TclGetString(objPtr);
- cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Free the old internalRep before setting the new one. Do this after
@@ -4288,22 +4403,23 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
-
+
Command *oldCmdPtr = resPtr->cmdPtr;
+
if (--oldCmdPtr->refCount == 0) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
TclFreeIntRep(objPtr);
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
@@ -4311,8 +4427,8 @@ SetCmdNameFromAny(
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
if ((*name++ == ':') && (*name == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * The name is fully qualified: set the referring namespace to
+ * NULL.
*/
resPtr->refNsPtr = NULL;
@@ -4322,7 +4438,7 @@ SetCmdNameFromAny(
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
-
+
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
@@ -4337,9 +4453,75 @@ SetCmdNameFromAny(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RepresentationCmd --
+ *
+ * Implementation of the "tcl::unsupported::representation" command.
+ *
+ * Results:
+ * Reports the current representation (Tcl_Obj type) of its argument.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RepresentationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ char refcountBuffer[TCL_INTEGER_SPACE+1];
+ char objPtrBuffer[TCL_INTEGER_SPACE+3];
+ char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2];
+#define TCLOBJ_TRUNCATE_STRINGREP 16
+ char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Value is a bignum with a refcount of 14, object pointer at 0x12345678,
+ * internal representation 0x45671234:0x98765432, string representation
+ * "1872361827361287"
+ */
+
+ sprintf(refcountBuffer, "%d", objv[1]->refCount);
+ sprintf(objPtrBuffer, "%p", (void *)objv[1]);
+ Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ?
+ objv[1]->typePtr->name : "pure string", " with a refcount of ",
+ refcountBuffer, ", object pointer at ", objPtrBuffer, NULL);
+ if (objv[1]->typePtr) {
+ sprintf(internalRepBuffer, "%p:%p",
+ (void *)objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *)objv[1]->internalRep.twoPtrValue.ptr2);
+ Tcl_AppendResult(interp, ", internal representation ",
+ internalRepBuffer, NULL);
+ }
+ if (objv[1]->bytes) {
+ strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP);
+ stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0;
+ Tcl_AppendResult(interp, ", string representation \"",
+ stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ?
+ "\"..." : "\".", NULL);
+ } else {
+ Tcl_AppendResult(interp, ", no string representation.", NULL);
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 600307e..2cb8aff 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -14,6 +14,9 @@
*/
#include "tclInt.h"
+#ifdef _WIN32
+ MODULE_SCOPE void tclWinDebugPanic(const char *format, ...);
+#endif
/*
* The panicProc variable contains a pointer to an application specific panic
@@ -21,13 +24,6 @@
*/
static Tcl_PanicProc *panicProc = NULL;
-
-/*
- * The platformPanicProc variable contains a pointer to a platform specific
- * panic procedure, if any. (TclpPanic may be NULL via a macro.)
- */
-
-static Tcl_PanicProc *CONST platformPanicProc = TclpPanic;
/*
*----------------------------------------------------------------------
@@ -49,6 +45,10 @@ void
Tcl_SetPanicProc(
Tcl_PanicProc *proc)
{
+#ifdef _WIN32
+ /* tclWinDebugPanic only installs if there is no panicProc yet. */
+ if ((proc != tclWinDebugPanic) || (panicProc == NULL))
+#endif
panicProc = proc;
}
@@ -70,13 +70,13 @@ Tcl_SetPanicProc(
void
Tcl_PanicVA(
- CONST char *format, /* Format string, suitable for passing to
+ const char *format, /* Format string, suitable for passing to
* fprintf. */
va_list argList) /* Variable argument list. */
{
- char *arg1, *arg2, *arg3, *arg4; /* Additional arguments (variable in
- * number) to pass to fprintf. */
- char *arg5, *arg6, *arg7, *arg8;
+ char *arg1, *arg2, *arg3; /* Additional arguments (variable in number)
+ * to pass to fprintf. */
+ char *arg4, *arg5, *arg6, *arg7, *arg8;
arg1 = va_arg(argList, char *);
arg2 = va_arg(argList, char *);
@@ -88,18 +88,32 @@ Tcl_PanicVA(
arg8 = va_arg(argList, char *);
if (panicProc != NULL) {
- (void) (*panicProc)(format, arg1, arg2, arg3, arg4,
- arg5, arg6, arg7, arg8);
- } else if (platformPanicProc != NULL) {
- (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4,
- arg5, arg6, arg7, arg8);
+ panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
+#ifdef _WIN32
+ } else if (IsDebuggerPresent()) {
+ tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
+#endif
} else {
- (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
- arg7, arg8);
- (void) fprintf(stderr, "\n");
- (void) fflush(stderr);
- abort();
+ fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
+ arg8);
+ fprintf(stderr, "\n");
+ fflush(stderr);
}
+ /* In case the users panic proc does not abort, we do it here */
+#ifdef _WIN32
+# if defined(__GNUC__)
+ __builtin_trap();
+# elif defined(_WIN64)
+ __debugbreak();
+# elif defined(_MSC_VER)
+ _asm {int 3}
+# else
+ DebugBreak();
+# endif
+ ExitProcess(1);
+#else
+ abort();
+#endif
}
/*
@@ -121,7 +135,7 @@ Tcl_PanicVA(
/* ARGSUSED */
void
Tcl_Panic(
- CONST char *format,
+ const char *format,
...)
{
va_list argList;
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 4e1e8b0..429d33a 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-
+
#include "tclInt.h"
/*
@@ -182,13 +182,13 @@ static int ParseWhiteSpace(const char *src, int numBytes,
*
* TclParseInit --
*
- * Initialize the fields of a Tcl_Parse struct.
+ * Initialize the fields of a Tcl_Parse struct.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * The Tcl_Parse struct pointed to by parsePtr gets initialized.
+ * The Tcl_Parse struct pointed to by parsePtr gets initialized.
*
*----------------------------------------------------------------------
*/
@@ -251,7 +251,7 @@ Tcl_ParseCommand(
* command terminator. If zero, then close
* bracket has no special meaning. */
register Tcl_Parse *parsePtr)
- /* Structure to fill in with information about
+ /* Structure to fill in with information about
* the parsed command; any previous
* information in the structure is ignored. */
{
@@ -467,7 +467,7 @@ Tcl_ParseCommand(
for(s=elemStart;size>0;s++,size--) {
if ((*s)=='\\') {
- nakedbs=1;
+ nakedbs = 1;
break;
}
}
@@ -479,11 +479,11 @@ Tcl_ParseCommand(
if ((code != TCL_OK) || nakedbs) {
/*
- * Some list element could not be parsed, or contained
- * naked backslashes. This means the literal string was
- * not in fact a valid nor canonical list. Defer the
- * handling of this to compile/eval time, where code is
- * already in place to report the "attempt to expand a
+ * Some list element could not be parsed, or contained
+ * naked backslashes. This means the literal string was
+ * not in fact a valid nor canonical list. Defer the
+ * handling of this to compile/eval time, where code is
+ * already in place to report the "attempt to expand a
* non-list" error or expand lists that require
* substitution.
*/
@@ -507,6 +507,7 @@ Tcl_ParseCommand(
int growthNeeded = wordIndex + 2*elemCount
- parsePtr->numTokens;
+
parsePtr->numWords += elemCount - 1;
if (growthNeeded > 0) {
TclGrowParseTokenArray(parsePtr, growthNeeded);
@@ -678,7 +679,7 @@ ParseWhiteSpace(
if (p[1] != '\n') {
break;
}
- p+=2;
+ p += 2;
if (--numBytes == 0) {
*incompletePtr = 1;
break;
@@ -763,7 +764,7 @@ TclParseHex(
break;
}
- ++p;
+ p++;
result <<= 4;
if (digit >= 'a') {
@@ -788,14 +789,14 @@ TclParseHex(
* sequence as defined by Tcl's parsing rules.
*
* Results:
- * Records at readPtr the number of bytes making up the backslash
- * sequence. Records at dst the UTF-8 encoded equivalent of that
- * backslash sequence. Returns the number of bytes written to dst, at
- * most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results
- * are not needed, but the return value is the same either way.
+ * Records at readPtr the number of bytes making up the backslash
+ * sequence. Records at dst the UTF-8 encoded equivalent of that
+ * backslash sequence. Returns the number of bytes written to dst, at
+ * most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results
+ * are not needed, but the return value is the same either way.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -911,21 +912,21 @@ TclParseBackslash(
*/
if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
- result = (unsigned char)(*p - '0');
+ result = UCHAR(*p - '0');
p++;
if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 3;
- result = (unsigned char)((result << 3) + (*p - '0'));
+ result = UCHAR((result << 3) + (*p - '0'));
p++;
if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 4;
- result = (unsigned char)((result << 3) + (*p - '0'));
+ result = UCHAR((result << 3) + (*p - '0'));
break;
}
@@ -964,11 +965,11 @@ TclParseBackslash(
* defined by Tcl's parsing rules.
*
* Results:
- * Records in parsePtr information about the parse. Returns the number of
- * bytes consumed.
+ * Records in parsePtr information about the parse. Returns the number of
+ * bytes consumed.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1121,7 +1122,7 @@ ParseTokens(
}
/*
- * This is a variable reference. Call Tcl_ParseVarName to do all
+ * This is a variable reference. Call Tcl_ParseVarName to do all
* the dirty work of parsing the name.
*/
@@ -1145,15 +1146,14 @@ ParseTokens(
}
/*
- * Command substitution. Call Tcl_ParseCommand recursively (and
+ * Command substitution. Call Tcl_ParseCommand recursively (and
* repeatedly) to parse the nested command(s), then throw away the
* parse information.
*/
src++;
numBytes--;
- nestedPtr = (Tcl_Parse *)
- TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
+ nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
nestedPtr) != TCL_OK) {
@@ -1299,7 +1299,7 @@ Tcl_FreeParse(
* call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
- ckfree((char *) parsePtr->tokenPtr);
+ ckfree(parsePtr->tokenPtr);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
@@ -1550,8 +1550,7 @@ Tcl_ParseVar(
{
register Tcl_Obj *objPtr;
int code;
- Tcl_Parse *parsePtr = (Tcl_Parse *)
- TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
TclStackFree(interp, parsePtr);
@@ -1634,7 +1633,7 @@ Tcl_ParseBraces(
* the string consists of all bytes up to the
* first null character. */
register Tcl_Parse *parsePtr,
- /* Structure to fill in with information about
+ /* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
@@ -1835,7 +1834,7 @@ Tcl_ParseQuotedString(
* the string consists of all bytes up to the
* first null character. */
register Tcl_Parse *parsePtr,
- /* Structure to fill in with information about
+ /* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
@@ -1883,33 +1882,42 @@ Tcl_ParseQuotedString(
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstObj --
- *
- * This function performs the substitutions specified on the given string
- * as described in the user documentation for the "subst" Tcl command.
+ * TclSubstParse --
*
+ * Token parser used by the [subst] command. Parses the string made up of
+ * 'numBytes' bytes starting at 'bytes'. Parsing is controlled by the
+ * flags argument to provide support for the -nobackslashes, -nocommands,
+ * and -novariables options, as represented by the flag values
+ * TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES.
+ *
* Results:
- * A Tcl_Obj* containing the substituted string, or NULL to indicate that
- * an error occurred.
+ * None.
*
* Side effects:
- * See the user documentation.
+ * The Tcl_Parse struct '*parsePtr' is filled with parse results.
+ * The caller is expected to eventually call Tcl_FreeParse() to properly
+ * cleanup the value written there.
+ *
+ * If a parse error occurs, the Tcl_InterpState value '*statePtr' is
+ * filled with the state created by that error. When *statePtr is written
+ * to, the caller is expected to make the required calls to either
+ * Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the
+ * value written there.
*
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-Tcl_SubstObj(
- Tcl_Interp *interp, /* Interpreter in which substitution occurs */
- Tcl_Obj *objPtr, /* The value to be substituted. */
- int flags) /* What substitutions to do. */
+void
+TclSubstParse(
+ Tcl_Interp *interp,
+ const char *bytes,
+ int numBytes,
+ int flags,
+ Tcl_Parse *parsePtr,
+ Tcl_InterpState *statePtr)
{
- int length, tokensLeft, code;
- Tcl_Token *endTokenPtr;
- Tcl_Obj *result, *errMsg = NULL;
- const char *p = TclGetStringFromObj(objPtr, &length);
- Tcl_Parse *parsePtr = (Tcl_Parse *)
- TclStackAlloc(interp, sizeof(Tcl_Parse));
+ int length = numBytes;
+ const char *p = bytes;
TclParseInit(interp, p, length, parsePtr);
@@ -1921,12 +1929,11 @@ Tcl_SubstObj(
if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
/*
- * There was a parse error. Save the error message for possible
- * reporting later.
+ * There was a parse error. Save the interpreter state for possible
+ * error reporting later.
*/
- errMsg = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(errMsg);
+ *statePtr = Tcl_SaveInterpState(interp, TCL_ERROR);
/*
* We need to re-parse to get the portion of the string we can [subst]
@@ -1992,10 +1999,10 @@ Tcl_SubstObj(
parsePtr->tokenPtr + parsePtr->numTokens - 2;
if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
- Tcl_Panic("Tcl_SubstObj: programming error");
+ Tcl_Panic("TclSubstParse: programming error");
}
if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
- Tcl_Panic("Tcl_SubstObj: programming error");
+ Tcl_Panic("TclSubstParse: programming error");
}
parsePtr->numTokens -= 2;
}
@@ -2024,7 +2031,7 @@ Tcl_SubstObj(
Tcl_Token *tokenPtr;
const char *lastTerm = parsePtr->term;
- Tcl_Parse *nestedPtr = (Tcl_Parse *)
+ Tcl_Parse *nestedPtr =
TclStackAlloc(interp, sizeof(Tcl_Parse));
while (TCL_OK ==
@@ -2069,64 +2076,9 @@ Tcl_SubstObj(
break;
default:
- Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
+ Tcl_Panic("bad parse in TclSubstParse: %c", p[length]);
}
}
-
- /*
- * Next, substitute the parsed tokens just as in normal Tcl evaluation.
- */
-
- endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
- tokensLeft = parsePtr->numTokens;
- code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
- &tokensLeft, 1, NULL, NULL);
- if (code == TCL_OK) {
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- if (errMsg != NULL) {
- Tcl_SetObjResult(interp, errMsg);
- Tcl_DecrRefCount(errMsg);
- return NULL;
- }
- return Tcl_GetObjResult(interp);
- }
-
- result = Tcl_NewObj();
- while (1) {
- switch (code) {
- case TCL_ERROR:
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- Tcl_DecrRefCount(result);
- if (errMsg != NULL) {
- Tcl_DecrRefCount(errMsg);
- }
- return NULL;
- case TCL_BREAK:
- tokensLeft = 0; /* Halt substitution */
- default:
- Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
- }
-
- if (tokensLeft == 0) {
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- if (errMsg != NULL) {
- if (code != TCL_BREAK) {
- Tcl_DecrRefCount(result);
- Tcl_SetObjResult(interp, errMsg);
- Tcl_DecrRefCount(errMsg);
- return NULL;
- }
- Tcl_DecrRefCount(errMsg);
- }
- return result;
- }
-
- code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
- &tokensLeft, 1, NULL, NULL);
- }
}
/*
@@ -2140,13 +2092,13 @@ Tcl_SubstObj(
* non-TCL_OK completion code arises.
*
* Results:
- * The return value is a standard Tcl completion code. The result in
- * interp is the substituted value, or an error message if TCL_ERROR is
- * returned. If tokensLeftPtr is not NULL, then it points to an int where
- * the number of tokens remaining to be processed is written.
+ * The return value is a standard Tcl completion code. The result in
+ * interp is the substituted value, or an error message if TCL_ERROR is
+ * returned. If tokensLeftPtr is not NULL, then it points to an int where
+ * the number of tokens remaining to be processed is written.
*
* Side effects:
- * Can be anything, depending on the types of substitution done.
+ * Can be anything, depending on the types of substitution done.
*
*----------------------------------------------------------------------
*/
@@ -2164,29 +2116,30 @@ TclSubstTokens(
* integer representing the number of tokens
* left to be substituted will be written */
int line, /* The line the script starts on. */
- int* clNextOuter, /* Information about an outer context for */
- CONST char* outerScript) /* continuation line data. This is set by
- * EvalEx() to properly handle [...]-nested
- * commands. The 'outerScript' refers to the
- * most-outer script containing the embedded
- * command, which is refered to by 'script'. The
- * 'clNextOuter' refers to the current entry in
- * the table of continuation lines in this
- * "master script", and the character offsets are
- * relative to the 'outerScript' as well.
- *
- * If outerScript == script, then this call is for
- * words in the outer-most script/command. See
- * Tcl_EvalEx() and TclEvalObjEx() for the places
- * generating arguments for which this is true.
- */
+ int *clNextOuter, /* Information about an outer context for */
+ const char *outerScript) /* continuation line data. This is set by
+ * EvalEx() to properly handle [...]-nested
+ * commands. The 'outerScript' refers to the
+ * most-outer script containing the embedded
+ * command, which is refered to by 'script'.
+ * The 'clNextOuter' refers to the current
+ * entry in the table of continuation lines in
+ * this "master script", and the character
+ * offsets are relative to the 'outerScript'
+ * as well.
+ *
+ * If outerScript == script, then this call is
+ * for words in the outer-most script or
+ * command. See Tcl_EvalEx and TclEvalObjEx
+ * for the places generating arguments for
+ * which this is true. */
{
Tcl_Obj *result;
int code = TCL_OK;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL, i, adjust;
- int* clPosition = NULL;
- Interp* iPtr = (Interp*) interp;
+ int *clPosition = NULL;
+ Interp *iPtr = (Interp *) interp;
int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
/*
@@ -2203,24 +2156,24 @@ TclSubstTokens(
* For the handling of continuation lines in literals we first check if
* this is actually a literal. For if not we can forego the additional
* processing. Otherwise we pre-allocate a small table to store the
- * locations of all continuation lines we find in this literal, if
- * any. The table is extended if needed.
+ * locations of all continuation lines we find in this literal, if any.
+ * The table is extended if needed.
*/
- numCL = 0;
- maxNumCL = 0;
+ numCL = 0;
+ maxNumCL = 0;
isLiteral = 1;
for (i=0 ; i < count; i++) {
- if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
- (tokenPtr[i].type != TCL_TOKEN_BS)) {
+ if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
+ && (tokenPtr[i].type != TCL_TOKEN_BS)) {
isLiteral = 0;
break;
}
}
if (isLiteral) {
- maxNumCL = NUM_STATIC_POS;
- clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
+ maxNumCL = NUM_STATIC_POS;
+ clPosition = ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2241,6 +2194,7 @@ TclSubstTokens(
appendByteLength = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfCharBytes);
append = utfCharBytes;
+
/*
* If the backslash sequence we found is in a literal, and
* represented a continuation line, we compute and store its
@@ -2256,10 +2210,11 @@ TclSubstTokens(
* correction.
*/
- if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') &&
- (tokenPtr->start[1] == '\n')) {
+ if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
+ && (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos;
+
if (result == 0) {
clPos = 0;
} else {
@@ -2268,19 +2223,18 @@ TclSubstTokens(
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = (int*) ckrealloc ((char*)clPosition,
- maxNumCL*sizeof(int));
+ clPosition = ckrealloc(clPosition,
+ maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
- numCL ++;
+ numCL++;
}
- adjust ++;
+ adjust++;
}
break;
case TCL_TOKEN_COMMAND: {
- Interp *iPtr = (Interp *) interp;
-
+ /* TIP #280: Transfer line information to nested command */
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
@@ -2289,21 +2243,27 @@ TclSubstTokens(
*/
int theline;
- TclAdvanceContinuations (&line, &clNextOuter,
- tokenPtr->start - outerScript);
+
+ TclAdvanceContinuations(&line, &clNextOuter,
+ tokenPtr->start - outerScript);
theline = line + adjust;
- /* TIP #280: Transfer line information to nested command */
code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
0, theline, clNextOuter, outerScript);
+
+ TclAdvanceLines(&line, tokenPtr->start+1,
+ tokenPtr->start + tokenPtr->size - 1);
+
/*
* Restore flag reset by nested eval for future bracketed
* commands and their cmdframe setup
*/
- if (inFile) {
+
+ if (inFile) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
}
iPtr->numLevels--;
+ TclResetCancellation(interp, 0);
appendObj = Tcl_GetObjResult(interp);
break;
}
@@ -2402,6 +2362,7 @@ TclSubstTokens(
if (code != TCL_ERROR) { /* Keep error message in result! */
if (result != NULL) {
Tcl_SetObjResult(interp, result);
+
/*
* If the code found continuation lines (which implies that this
* word is a literal), then we store the accumulated table of
@@ -2420,7 +2381,7 @@ TclSubstTokens(
*/
if (maxNumCL) {
- ckfree ((char*) clPosition);
+ ckfree(clPosition);
}
} else {
Tcl_ResetResult(interp);
@@ -2564,8 +2525,8 @@ TclIsLocalScalar(
const char *lastChar = src + (len - 1);
for (p=src ; p<=lastChar ; p++) {
- if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
- (CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
+ if ((CHAR_TYPE(*p) != TYPE_NORMAL)
+ && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
/*
* TCL_COMMAND_END is returned for the last character of the
* string. By this point we know it isn't an array or namespace
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index da3b280..d9e3973 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -33,7 +33,7 @@ static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
* internally.
*/
-static Tcl_ObjType tclFsPathType = {
+static const Tcl_ObjType tclFsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -237,7 +237,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- (void) Tcl_GetStringFromObj(retVal, &curLen);
+ Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -249,7 +249,7 @@ TclFSNormalizeAbsolutePath(
continue;
}
if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
- Tcl_Obj *link;
+ Tcl_Obj *linkObj;
int curLen;
char *linkStr;
@@ -263,21 +263,22 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- (void) Tcl_GetStringFromObj(retVal, &curLen);
+ Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
- link = Tcl_FSLink(retVal, NULL, 0);
- if (link != NULL) {
+ linkObj = Tcl_FSLink(retVal, NULL, 0);
+ if (linkObj != NULL) {
/*
* Got a link. Need to check if the link is relative
* or absolute, for those platforms where relative
* links exist.
*/
- if (tclPlatform != TCL_PLATFORM_WINDOWS &&
- Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) {
+ if (tclPlatform != TCL_PLATFORM_WINDOWS
+ && Tcl_FSGetPathType(linkObj)
+ == TCL_PATH_RELATIVE) {
/*
* We need to follow this link which is relative
* to retVal's directory. This means concatenating
@@ -303,8 +304,8 @@ TclFSNormalizeAbsolutePath(
*/
Tcl_SetObjLength(retVal, curLen+1);
- Tcl_AppendObjToObj(retVal, link);
- TclDecrRefCount(link);
+ Tcl_AppendObjToObj(retVal, linkObj);
+ TclDecrRefCount(linkObj);
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
} else {
/*
@@ -312,7 +313,7 @@ TclFSNormalizeAbsolutePath(
*/
TclDecrRefCount(retVal);
- retVal = link;
+ retVal = linkObj;
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
/*
@@ -334,8 +335,8 @@ TclFSNormalizeAbsolutePath(
}
/*
- * Either way, we now remove the last path element.
- * (but not the first character of the path)
+ * Either way, we now remove the last path element (but
+ * not the first character of the path).
*/
while (--curLen >= 0) {
@@ -396,7 +397,7 @@ TclFSNormalizeAbsolutePath(
}
/*
- * Ensure a windows drive like C:/ has a trailing separator
+ * Ensure a windows drive like C:/ has a trailing separator.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
@@ -494,7 +495,7 @@ Tcl_FSGetPathType(
Tcl_PathType
TclFSGetPathType(
Tcl_Obj *pathPtr,
- Tcl_Filesystem **filesystemPtrPtr,
+ const Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr)
{
FsPath *fsPathPtr;
@@ -831,7 +832,7 @@ Tcl_FSJoinPath(
{
Tcl_Obj *res;
int i;
- Tcl_Filesystem *fsPtr = NULL;
+ const Tcl_Filesystem *fsPtr = NULL;
if (elements < 0) {
if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
@@ -877,17 +878,18 @@ Tcl_FSJoinPath(
* could expand that in the future.
*/
- if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
- && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
- Tcl_Obj *tail;
+ if ((i == (elements-2)) && (i == 0)
+ && (elt->typePtr == &tclFsPathType)
+ && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) {
+ Tcl_Obj *tailObj;
- Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
- type = TclGetPathType(tail, NULL, NULL, NULL);
+ Tcl_ListObjIndex(NULL, listObj, i+1, &tailObj);
+ type = TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
- str = Tcl_GetStringFromObj(tail, &len);
+ str = Tcl_GetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
@@ -935,16 +937,16 @@ Tcl_FSJoinPath(
if (res != NULL) {
TclDecrRefCount(res);
}
- return tail;
+ return tailObj;
} else {
- const char *str = TclGetString(tail);
+ const char *str = TclGetString(tailObj);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
if (res != NULL) {
TclDecrRefCount(res);
}
- return tail;
+ return tailObj;
}
}
}
@@ -1021,8 +1023,8 @@ Tcl_FSJoinPath(
}
/*
- * This element is just what we want to return already - no
- * further manipulation is requred.
+ * This element is just what we want to return already; no further
+ * manipulation is requred.
*/
return elt;
@@ -1068,7 +1070,7 @@ Tcl_FSJoinPath(
int needsSep = 0;
if (fsPtr->filesystemSeparatorProc != NULL) {
- Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
+ Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);
if (sep != NULL) {
separator = TclGetString(sep)[0];
@@ -1295,7 +1297,7 @@ TclNewFSPathObj(
tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
pathPtr = Tcl_NewObj();
- fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+ fsPathPtr = ckalloc(sizeof(FsPath));
/*
* Set up the path.
@@ -1318,41 +1320,41 @@ TclNewFSPathObj(
/*
* Look for path components made up of only "."
- * This is overly conservative analysis to keep simple. It may
- * mark some things as needing more aggressive normalization
- * that don't actually need it. No harm done.
+ * This is overly conservative analysis to keep simple. It may mark some
+ * things as needing more aggressive normalization that don't actually
+ * need it. No harm done.
*/
for (p = addStrRep; len > 0; p++, len--) {
- switch (state) {
- case 0: /* So far only "." since last dirsep or start */
- switch (*p) {
- case '.':
- count++;
- break;
- case '/':
- case '\\':
- case ':':
- if (count) {
- PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
- len = 0;
- }
- break;
- default:
- count = 0;
- state = 1;
- }
- case 1: /* Scanning for next dirsep */
- switch (*p) {
- case '/':
- case '\\':
- case ':':
- state = 0;
- break;
- }
- }
+ switch (state) {
+ case 0: /* So far only "." since last dirsep or start */
+ switch (*p) {
+ case '.':
+ count++;
+ break;
+ case '/':
+ case '\\':
+ case ':':
+ if (count) {
+ PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
+ len = 0;
+ }
+ break;
+ default:
+ count = 0;
+ state = 1;
+ }
+ case 1: /* Scanning for next dirsep */
+ switch (*p) {
+ case '/':
+ case '\\':
+ case ':':
+ state = 0;
+ break;
+ }
+ }
}
if (len == 0 && count) {
- PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
+ PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
}
return pathPtr;
@@ -1431,77 +1433,13 @@ TclFSMakePathRelative(
{
int cwdLen, len;
const char *tempStr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (pathPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0
&& fsPathPtr->cwdPtr == cwdPtr) {
- pathPtr = fsPathPtr->normPathPtr;
-
- /* TODO: Determine how much, if any, of this forcing
- * the relative path tail into the "path" Tcl_ObjType
- * with a recorded cwdPtr context has any actual value.
- *
- * Nothing is getting cached. Not normPathPtr, not nativePathPtr,
- * nor fsRecPtr, so storing the cwdPtr context against which such
- * cached values might later be validated appears to be of no
- * value. Take that away, and all this code is just a mildly
- * optimized equivalent of a call to SetFsPathFromAny(). That
- * optimization may have some value, *if* these value in fact
- * get used as "path" values before used as something else.
- * If not, though, whatever cost we pay below to convert to
- * one of the "path" intreps is just a waste, it seems. The
- * usual convention in the core is to delay ObjType conversion
- * until it is needed and demanded, and I don't see why this
- * section of code should be an exception to that. Leaving it
- * in place for the rest of the 8.5.* releases just for sake
- * of stability.
- */
-
- /*
- * Free old representation.
- */
-
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't find object"
- "string representation", NULL);
- }
- return NULL;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
- /*
- * Now pathPtr is a string object.
- */
-
- fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
-
- /*
- * Circular reference, by design.
- */
-
- fsPathPtr->translatedPathPtr = pathPtr;
- fsPathPtr->normPathPtr = NULL;
- fsPathPtr->cwdPtr = cwdPtr;
- Tcl_IncrRefCount(cwdPtr);
- fsPathPtr->nativePathPtr = NULL;
- fsPathPtr->fsRecPtr = NULL;
- fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
-
- SETPATHOBJ(pathPtr, fsPathPtr);
- PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
-
- return pathPtr;
+ return fsPathPtr->normPathPtr;
}
}
@@ -1583,6 +1521,8 @@ TclFSMakePathFromNormalized(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object"
"string representation", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
+ NULL);
}
return TCL_ERROR;
}
@@ -1591,7 +1531,7 @@ TclFSMakePathFromNormalized(
TclFreeIntRep(pathPtr);
}
- fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+ fsPathPtr = ckalloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
@@ -1643,7 +1583,7 @@ TclFSMakePathFromNormalized(
Tcl_Obj *
Tcl_FSNewNativePath(
- Tcl_Filesystem *fromFilesystem,
+ const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
{
Tcl_Obj *pathPtr;
@@ -1673,7 +1613,7 @@ Tcl_FSNewNativePath(
TclFreeIntRep(pathPtr);
}
- fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+ fsPathPtr = ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
@@ -1742,7 +1682,7 @@ Tcl_FSGetTranslatedPath(
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
- &(srcFsPathPtr->normPathPtr));
+ &srcFsPathPtr->normPathPtr);
srcFsPathPtr->translatedPathPtr = retObj;
Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
@@ -1798,7 +1738,7 @@ Tcl_FSGetTranslatedStringPath(
if (transPtr != NULL) {
int len;
const char *orig = Tcl_GetStringFromObj(transPtr, &len);
- char *result = (char *) ckalloc((unsigned) len+1);
+ char *result = ckalloc(len+1);
memcpy(result, orig, (size_t) len+1);
TclDecrRefCount(transPtr);
@@ -1874,25 +1814,25 @@ Tcl_FSGetNormalizedPath(
if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) {
/*
- * If the "tail" part has components (like /../) that cause
- * the combined path to need more complete normalizing,
- * call on the more powerful routine to accomplish that so
- * we avoid [Bug 2385549] ...
+ * If the "tail" part has components (like /../) that cause the
+ * combined path to need more complete normalizing, call on the
+ * more powerful routine to accomplish that so we avoid [Bug
+ * 2385549] ...
*/
Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL);
+
Tcl_DecrRefCount(copy);
copy = newCopy;
} else {
/*
- * ... but in most cases where we join a trouble free tail
- * to a normalized head, we can more efficiently normalize the
- * combined path by passing over only the unnormalized tail
- * portion. When this is sufficient, prior developers claim
- * this should be much faster. We use 'cwdLen-1' so that we are
- * already pointing at the dir-separator that we know about.
- * The normalization code will actually start off directly
- * after that separator.
+ * ... but in most cases where we join a trouble free tail to a
+ * normalized head, we can more efficiently normalize the combined
+ * path by passing over only the unnormalized tail portion. When
+ * this is sufficient, prior developers claim this should be much
+ * faster. We use 'cwdLen-1' so that we are already pointing at
+ * the dir-separator that we know about. The normalization code
+ * will actually start off directly after that separator.
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
@@ -1906,11 +1846,11 @@ Tcl_FSGetNormalizedPath(
/*
* NOTE: here we are (dangerously?) assuming that origDir points
- * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType . The
+ * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The
* pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
- * above that set the pathType value should have established
- * that, but it's far less clear on what basis we know there's
- * been no shimmering since then.
+ * above that set the pathType value should have established that,
+ * but it's far less clear on what basis we know there's been no
+ * shimmering since then.
*/
FsPath *origDirFsPathPtr = PATHOBJ(origDir);
@@ -1942,8 +1882,8 @@ Tcl_FSGetNormalizedPath(
if (clientData != NULL) {
/*
* This may be unnecessary. It appears that the
- * TclFSNormalizeToUniquePath call above should have already
- * set this up. Not changing out of fear of the unknown.
+ * TclFSNormalizeToUniquePath call above should have already set
+ * this up. Not changing out of fear of the unknown.
*/
fsPathPtr->nativePathPtr = clientData;
@@ -2013,11 +1953,11 @@ Tcl_FSGetNormalizedPath(
if (path[0] == '\0') {
/*
- * Special handling for the empty string value. This one is
- * very weird with [file normalize {}] => {}. (The reasoning
- * supporting this is unknown to DGP, but he fears changing it.)
- * Attempt here to keep the expectations of other parts of
- * Tcl_Filesystem code about state of the FsPath fields satisfied.
+ * Special handling for the empty string value. This one is very
+ * weird with [file normalize {}] => {}. (The reasoning supporting
+ * this is unknown to DGP, but he fears changing it.) Attempt here
+ * to keep the expectations of other parts of Tcl_Filesystem code
+ * about state of the FsPath fields satisfied.
*
* In particular, capture the cwd value and save so it can be
* stored in the cwdPtr field below.
@@ -2076,7 +2016,7 @@ Tcl_FSGetNormalizedPath(
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
if (0 && (clientData != NULL)) {
fsPathPtr->nativePathPtr =
- (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
+ fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc(clientData);
}
/*
@@ -2085,8 +2025,12 @@ Tcl_FSGetNormalizedPath(
*/
if (pureNormalized) {
- if (!strcmp(TclGetString(fsPathPtr->normPathPtr),
- TclGetString(pathPtr))) {
+ int normPathLen, pathLen;
+ const char *normPath;
+
+ path = TclGetStringFromObj(pathPtr, &pathLen);
+ normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen);
+ if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) {
/*
* The path was already normalized. Get rid of the duplicate.
*/
@@ -2141,7 +2085,7 @@ Tcl_FSGetNormalizedPath(
ClientData
Tcl_FSGetInternalRep(
Tcl_Obj *pathPtr,
- Tcl_Filesystem *fsPtr)
+ const Tcl_Filesystem *fsPtr)
{
FsPath *srcFsPathPtr;
@@ -2214,7 +2158,7 @@ Tcl_FSGetInternalRep(
return NULL;
}
- nativePathPtr = (*proc)(pathPtr);
+ nativePathPtr = proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
}
@@ -2243,7 +2187,7 @@ Tcl_FSGetInternalRep(
int
TclFSEnsureEpochOk(
Tcl_Obj *pathPtr,
- Tcl_Filesystem **fsPtrPtr)
+ const Tcl_Filesystem **fsPtrPtr)
{
FsPath *srcFsPathPtr;
@@ -2347,7 +2291,7 @@ Tcl_FSEqualPaths(
Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr)
{
- char *firstStr, *secondStr;
+ const char *firstStr, *secondStr;
int firstLen, secondLen, tempErrno;
if (firstPtr == secondPtr) {
@@ -2357,9 +2301,9 @@ Tcl_FSEqualPaths(
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
- firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
- secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
- if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
+ firstStr = TclGetStringFromObj(firstPtr, &firstLen);
+ secondStr = TclGetStringFromObj(secondPtr, &secondLen);
+ if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
return 1;
}
@@ -2377,9 +2321,9 @@ Tcl_FSEqualPaths(
return 0;
}
- firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
- secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
- return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0);
+ firstStr = TclGetStringFromObj(firstPtr, &firstLen);
+ secondStr = TclGetStringFromObj(secondPtr, &secondLen);
+ return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}
/*
@@ -2414,7 +2358,7 @@ SetFsPathFromAny(
#if defined(__CYGWIN__) && defined(__WIN32__)
int copied = 0;
#endif
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
@@ -2477,6 +2421,8 @@ SetFsPathFromAny(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't find HOME environment "
"variable to expand path", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
+ "HOMELESS", NULL);
}
return TCL_ERROR;
}
@@ -2494,6 +2440,8 @@ SetFsPathFromAny(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", name+1,
"\" doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
+ NULL);
}
Tcl_DStringFree(&temp);
if (split != len) {
@@ -2586,7 +2534,7 @@ SetFsPathFromAny(
* slashes on Windows, and will not contain any ~user sequences.
*/
- fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+ fsPathPtr = ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
if (transPtr != pathPtr) {
@@ -2640,7 +2588,7 @@ FreeFsPathInternalRep(
fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc;
if (freeProc != NULL) {
- (*freeProc)(fsPathPtr->nativePathPtr);
+ freeProc(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
@@ -2651,11 +2599,11 @@ FreeFsPathInternalRep(
* It has been unregistered already.
*/
- ckfree((char *) fsPathPtr->fsRecPtr);
+ ckfree(fsPathPtr->fsRecPtr);
}
}
- ckfree((char *) fsPathPtr);
+ ckfree(fsPathPtr);
pathPtr->typePtr = NULL;
}
@@ -2665,7 +2613,7 @@ DupFsPathInternalRep(
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
- FsPath *copyFsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+ FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
@@ -2703,7 +2651,7 @@ DupFsPathInternalRep(
if (dupProc != NULL) {
copyFsPathPtr->nativePathPtr =
- (*dupProc)(srcFsPathPtr->nativePathPtr);
+ dupProc(srcFsPathPtr->nativePathPtr);
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index dd70e5e..5f59c38 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -32,8 +32,8 @@ TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */
* Declarations for local functions defined in this file:
*/
-static TclFile FileForRedirect(Tcl_Interp *interp, CONST char *spec,
- int atOk, CONST char *arg, CONST char *nextArg,
+static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec,
+ int atOk, const char *arg, const char *nextArg,
int flags, int *skipPtr, int *closePtr,
int *releasePtr);
@@ -61,14 +61,14 @@ static TclFile FileForRedirect(Tcl_Interp *interp, CONST char *spec,
static TclFile
FileForRedirect(
Tcl_Interp *interp, /* Intepreter to use for error reporting. */
- CONST char *spec, /* Points to character just after redirection
+ const char *spec, /* Points to character just after redirection
* character. */
int atOK, /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
- CONST char *arg, /* Pointer to entire argument containing spec:
+ const char *arg, /* Pointer to entire argument containing spec:
* used for error reporting. */
- CONST char *nextArg, /* Next argument in argc/argv array, if needed
+ const char *nextArg, /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags, /* Flags to use for opening file or to specify
@@ -94,23 +94,26 @@ FileForRedirect(
}
*skipPtr = 2;
}
- chan = Tcl_GetChannel(interp, spec, NULL);
- if (chan == (Tcl_Channel) NULL) {
- return NULL;
- }
+ chan = Tcl_GetChannel(interp, spec, NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return NULL;
+ }
file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
- if (file == NULL) {
- Tcl_Obj* msg;
+ if (file == NULL) {
+ Tcl_Obj *msg;
+
Tcl_GetChannelError(chan, &msg);
if (msg) {
- Tcl_SetObjResult (interp, msg);
+ Tcl_SetObjResult(interp, msg);
} else {
- Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
- "\" wasn't opened for ",
- ((writing) ? "writing" : "reading"), NULL);
+ Tcl_AppendResult(interp, "channel \"",
+ Tcl_GetChannelName(chan), "\" wasn't opened for ",
+ ((writing) ? "writing" : "reading"), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "BADCHAN", NULL);
}
- return NULL;
- }
+ return NULL;
+ }
*releasePtr = 1;
if (writing) {
/*
@@ -118,10 +121,10 @@ FileForRedirect(
* by the child appears after stuff we've already written.
*/
- Tcl_Flush(chan);
+ Tcl_Flush(chan);
}
} else {
- CONST char *name;
+ const char *name;
Tcl_DString nameString;
if (*spec == '\0') {
@@ -143,13 +146,14 @@ FileForRedirect(
Tcl_PosixError(interp), NULL);
return NULL;
}
- *closePtr = 1;
+ *closePtr = 1;
}
return file;
badLastArg:
Tcl_AppendResult(interp, "can't specify \"", arg,
"\" as last word in command", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
return NULL;
}
@@ -182,7 +186,7 @@ Tcl_DetachPids(
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
- detPtr = (Detached *) ckalloc(sizeof(Detached));
+ detPtr = ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
@@ -232,7 +236,7 @@ Tcl_ReapDetachedProcs(void)
} else {
prevPtr->nextPtr = detPtr->nextPtr;
}
- ckfree((char *) detPtr);
+ ckfree(detPtr);
detPtr = nextPtr;
}
Tcl_MutexUnlock(&pipeMutex);
@@ -272,8 +276,8 @@ TclCleanupChildren(
int result = TCL_OK;
int i, abnormalExit, anyErrorInfo;
Tcl_Pid pid;
- WAIT_STATUS_TYPE waitStatus;
- CONST char *msg;
+ int waitStatus;
+ const char *msg;
unsigned long resolvedPid;
abnormalExit = 0;
@@ -285,24 +289,24 @@ TclCleanupChildren(
*/
resolvedPid = TclpGetPid(pidPtr[i]);
- pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
+ pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
if (pid == (Tcl_Pid) -1) {
result = TCL_ERROR;
- if (interp != NULL) {
- msg = Tcl_PosixError(interp);
- if (errno == ECHILD) {
+ if (interp != NULL) {
+ msg = Tcl_PosixError(interp);
+ if (errno == ECHILD) {
/*
- * This changeup in message suggested by Mark Diekhans to
- * remind people that ECHILD errors can occur on some
- * systems if SIGCHLD isn't in its default state.
- */
-
- msg =
- "child process lost (is SIGCHLD ignored or trapped?)";
- }
- Tcl_AppendResult(interp, "error waiting for process to exit: ",
- msg, NULL);
- }
+ * This changeup in message suggested by Mark Diekhans to
+ * remind people that ECHILD errors can occur on some
+ * systems if SIGCHLD isn't in its default state.
+ */
+
+ msg =
+ "child process lost (is SIGCHLD ignored or trapped?)";
+ }
+ Tcl_AppendResult(interp, "error waiting for process to exit: ",
+ msg, NULL);
+ }
continue;
}
@@ -319,32 +323,31 @@ TclCleanupChildren(
result = TCL_ERROR;
sprintf(msg1, "%lu", resolvedPid);
if (WIFEXITED(waitStatus)) {
- if (interp != (Tcl_Interp *) NULL) {
- sprintf(msg2, "%lu",
- (unsigned long) WEXITSTATUS(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
- }
+ if (interp != NULL) {
+ sprintf(msg2, "%u", WEXITSTATUS(waitStatus));
+ Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
+ }
abnormalExit = 1;
} else if (interp != NULL) {
- CONST char *p;
+ const char *p;
if (WIFSIGNALED(waitStatus)) {
- p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
- Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
- Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
- NULL);
- Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL);
+ p = Tcl_SignalMsg(WTERMSIG(waitStatus));
+ Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
+ Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
+ Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL);
} else if (WIFSTOPPED(waitStatus)) {
- p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
- Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
- Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p,
+ p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
+ Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
+ Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
+ Tcl_AppendResult(interp, "child suspended: ", p, "\n",
NULL);
- Tcl_AppendResult(interp, "child suspended: ", p, "\n",
- NULL);
} else {
- Tcl_AppendResult(interp,
- "child wait status didn't make sense\n", NULL);
- }
+ Tcl_AppendResult(interp,
+ "child wait status didn't make sense\n", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "ODDWAITRESULT", msg1, NULL);
+ }
}
}
}
@@ -360,7 +363,7 @@ TclCleanupChildren(
* Make sure we start at the beginning of the file.
*/
- if (interp != NULL) {
+ if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
@@ -428,7 +431,7 @@ int
TclCreatePipeline(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
int argc, /* Number of entries in argv. */
- CONST char **argv, /* Array of strings describing commands in
+ const char **argv, /* Array of strings describing commands in
* pipeline plus I/O redirection with <, <<,
* >, etc. Argv[argc] must be NULL. */
Tcl_Pid **pidArrayPtr, /* Word at *pidArrayPtr gets filled in with
@@ -464,7 +467,7 @@ TclCreatePipeline(
* *pidPtr right now. */
int cmdCount; /* Count of number of distinct commands found
* in argc/argv. */
- CONST char *inputLiteral = NULL;
+ const char *inputLiteral = NULL;
/* If non-null, then this points to a string
* containing input data (specified via <<) to
* be piped to the first process in the
@@ -473,22 +476,22 @@ TclCreatePipeline(
* first process in pipeline (specified via <
* or <@). */
int inputClose = 0; /* If non-zero, then inputFile should be
- * closed when cleaning up. */
+ * closed when cleaning up. */
int inputRelease = 0;
TclFile outputFile = NULL; /* Writable file for output from last command
* in pipeline (could be file or pipe). NULL
* means use stdout. */
int outputClose = 0; /* If non-zero, then outputFile should be
- * closed when cleaning up. */
+ * closed when cleaning up. */
int outputRelease = 0;
TclFile errorFile = NULL; /* Writable file for error output from all
* commands in pipeline. NULL means use
* stderr. */
int errorClose = 0; /* If non-zero, then errorFile should be
- * closed when cleaning up. */
+ * closed when cleaning up. */
int errorRelease = 0;
- CONST char *p;
- CONST char *nextArg;
+ const char *p;
+ const char *nextArg;
int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0;
Tcl_DString execBuffer;
TclFile pipeIn;
@@ -541,6 +544,8 @@ TclCreatePipeline(
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetResult(interp, "illegal use of | or |& in command",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "PIPESYNTAX", NULL);
goto error;
}
}
@@ -567,6 +572,8 @@ TclCreatePipeline(
if (inputLiteral == NULL) {
Tcl_AppendResult(interp, "can't specify \"", argv[i],
"\" as last word in command", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "PIPESYNTAX", NULL);
goto error;
}
skip = 2;
@@ -675,6 +682,8 @@ TclCreatePipeline(
if (i != argc-1) {
Tcl_AppendResult(interp, "must specify \"", argv[i],
"\" as last word in command", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "PIPESYNTAX", NULL);
goto error;
}
errorFile = outputFile;
@@ -691,9 +700,12 @@ TclCreatePipeline(
break;
default:
- /* Got a command word, not a redirection */
- needCmd = 0;
- break;
+ /*
+ * Got a command word, not a redirection.
+ */
+
+ needCmd = 0;
+ break;
}
if (skip != 0) {
@@ -706,11 +718,14 @@ TclCreatePipeline(
}
if (needCmd) {
- /* We had a bar followed only by redirections. */
+ /*
+ * We had a bar followed only by redirections.
+ */
- Tcl_SetResult(interp,
- "illegal use of | or |& in command",
- TCL_STATIC);
+ Tcl_SetResult(interp, "illegal use of | or |& in command",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
+ NULL);
goto error;
}
@@ -833,14 +848,14 @@ TclCreatePipeline(
*/
Tcl_ReapDetachedProcs();
- pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid)));
+ pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
- CONST char *oldName;
+ const char *oldName;
/*
* Convert the program name into native form.
@@ -986,7 +1001,7 @@ TclCreatePipeline(
Tcl_DetachPids(1, &pidPtr[i]);
}
}
- ckfree((char *) pidPtr);
+ ckfree(pidPtr);
}
numPids = -1;
goto cleanup;
@@ -1027,9 +1042,9 @@ TclCreatePipeline(
Tcl_Channel
Tcl_OpenCommandChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
- * NULL. */
+ * NULL. */
int argc, /* How many arguments. */
- CONST char **argv, /* Array of arguments for command pipe. */
+ const char **argv, /* Array of arguments for command pipe. */
int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
{
@@ -1046,7 +1061,7 @@ Tcl_OpenCommandChannel(
errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;
numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
- outPipePtr, errFilePtr);
+ outPipePtr, errFilePtr);
if (numPids < 0) {
goto error;
@@ -1061,11 +1076,15 @@ Tcl_OpenCommandChannel(
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
Tcl_AppendResult(interp, "can't read output from command:"
" standard output was redirected", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "BADREDIRECT", NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
Tcl_AppendResult(interp, "can't write input to command:"
" standard input was redirected", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+ "BADREDIRECT", NULL);
goto error;
}
}
@@ -1073,9 +1092,10 @@ Tcl_OpenCommandChannel(
channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
numPids, pidPtr);
- if (channel == (Tcl_Channel) NULL) {
- Tcl_AppendResult(interp, "pipe for command could not be created",
- NULL);
+ if (channel == NULL) {
+ Tcl_AppendResult(interp, "pipe for command could not be created",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
return channel;
@@ -1083,7 +1103,7 @@ Tcl_OpenCommandChannel(
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
- ckfree((char *) pidPtr);
+ ckfree(pidPtr);
}
if (inPipe != NULL) {
TclpCloseFile(inPipe);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index aed80c0..67503cb 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -46,7 +46,7 @@ typedef struct Package {
* exist in this interpreter yet. */
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
- ClientData clientData; /* Client data. */
+ const void *clientData; /* Client data. */
} Package;
/*
@@ -71,7 +71,7 @@ static void AddRequirementsToDString(Tcl_DString *dstring,
static Package * FindPackage(Tcl_Interp *interp, const char *name);
static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
int reqc, Tcl_Obj *const reqv[],
- ClientData *clientDataPtr);
+ void *clientDataPtr);
/*
* Helper macros.
@@ -122,7 +122,7 @@ Tcl_PkgProvideEx(
* available. */
const char *name, /* Name of package. */
const char *version, /* Version string for package. */
- ClientData clientData) /* clientdata for this package (normally used
+ const void *clientData) /* clientdata for this package (normally used
* for C callback function table) */
{
Package *pkgPtr;
@@ -156,6 +156,7 @@ Tcl_PkgProvideEx(
}
Tcl_AppendResult(interp, "conflicting versions provided for package \"",
name, "\": ", pkgPtr->version, ", then ", version, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
@@ -210,7 +211,7 @@ Tcl_PkgRequireEx(
int exact, /* Non-zero means that only the particular
* version given is acceptable. Zero means use
* the latest compatible version. */
- ClientData *clientDataPtr) /* Used to return the client data for this
+ void *clientDataPtr) /* Used to return the client data for this
* package. If it is NULL then the client data
* is not returned. This is unchanged if this
* call fails for any reason. */
@@ -286,6 +287,7 @@ Tcl_PkgRequireEx(
Tcl_AppendResult(interp, "Cannot load package \"", name,
"\" in standalone executable: This package is not "
"compiled with stub support", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
return NULL;
}
@@ -321,7 +323,7 @@ Tcl_PkgRequireProc(
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ void *clientDataPtr)
{
const char *result =
PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
@@ -342,7 +344,7 @@ PkgRequireCore(
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ void *clientDataPtr)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
@@ -376,6 +378,7 @@ PkgRequireCore(
"attempt to provide ", name, " ",
(char *) pkgPtr->clientData, " requires ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return NULL;
}
@@ -422,7 +425,9 @@ PkgRequireCore(
}
}
- /* We have found a version which is better than our max. */
+ /*
+ * We have found a version which is better than our max.
+ */
if (reqc > 0) {
/* Check satisfaction of requirements. */
@@ -475,14 +480,14 @@ PkgRequireCore(
* will still exist when the script completes.
*/
- const char *versionToProvide = bestPtr->version;
+ char *versionToProvide = bestPtr->version;
script = bestPtr->script;
- pkgPtr->clientData = (ClientData) versionToProvide;
- Tcl_Preserve((ClientData) script);
- Tcl_Preserve((ClientData) versionToProvide);
+ pkgPtr->clientData = versionToProvide;
+ Tcl_Preserve(script);
+ Tcl_Preserve(versionToProvide);
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
- Tcl_Release((ClientData) script);
+ Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
@@ -493,6 +498,8 @@ PkgRequireCore(
name, " ", versionToProvide,
" failed: no version of package ", name,
" provided", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
+ NULL);
} else {
char *pvi, *vi;
@@ -515,6 +522,8 @@ PkgRequireCore(
versionToProvide, " failed: package ",
name, " ", pkgPtr->version,
" provided instead", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+ "WRONGPROVIDE", NULL);
}
}
}
@@ -525,6 +534,7 @@ PkgRequireCore(
Tcl_AppendResult(interp, "attempt to provide package ", name,
" ", versionToProvide, " failed: bad return code: ",
TclGetString(codePtr), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
code = TCL_ERROR;
}
@@ -534,7 +544,7 @@ PkgRequireCore(
"\n (\"package ifneeded %s %s\" script)",
name, versionToProvide));
}
- Tcl_Release((ClientData) versionToProvide);
+ Tcl_Release(versionToProvide);
if (code != TCL_OK) {
/*
@@ -582,9 +592,11 @@ PkgRequireCore(
if ((code != TCL_OK) && (code != TCL_ERROR)) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
+
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad return code: ",
TclGetString(codePtr), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
@@ -599,6 +611,7 @@ PkgRequireCore(
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
}
@@ -608,26 +621,28 @@ PkgRequireCore(
* provided version meets the current requirements.
*/
- if (reqc == 0) {
- satisfies = 1;
- } else {
+ if (reqc != 0) {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
- }
- if (satisfies) {
- if (clientDataPtr) {
- *clientDataPtr = pkgPtr->clientData;
+ if (!satisfies) {
+ Tcl_AppendResult(interp, "version conflict for package \"", name,
+ "\": have ", pkgPtr->version, ", need", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+ NULL);
+ AddRequirementsToResult(interp, reqc, reqv);
+ return NULL;
}
- return pkgPtr->version;
}
- Tcl_AppendResult(interp, "version conflict for package \"", name,
- "\": have ", pkgPtr->version, ", need", NULL);
- AddRequirementsToResult(interp, reqc, reqv);
- return NULL;
+ if (clientDataPtr) {
+ const void **ptr = (const void **) clientDataPtr;
+
+ *ptr = pkgPtr->clientData;
+ }
+ return pkgPtr->version;
}
/*
@@ -675,7 +690,7 @@ Tcl_PkgPresentEx(
int exact, /* Non-zero means that only the particular
* version given is acceptable. Zero means use
* the latest compatible version. */
- ClientData *clientDataPtr) /* Used to return the client data for this
+ void *clientDataPtr) /* Used to return the client data for this
* package. If it is NULL then the client data
* is not returned. This is unchanged if this
* call fails for any reason. */
@@ -740,7 +755,7 @@ Tcl_PackageObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *pkgOptions[] = {
+ static const char *const pkgOptions[] = {
"forget", "ifneeded", "names", "prefer", "present",
"provide", "require", "unknown", "vcompare", "versions",
"vsatisfies", NULL
@@ -758,10 +773,11 @@ Tcl_PackageObjCmd(
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
const char *version;
- char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL;
+ const char *argv2, *argv3, *argv4;
+ char *iva = NULL, *ivb = NULL;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
@@ -771,7 +787,7 @@ Tcl_PackageObjCmd(
}
switch ((enum pkgOptions) optionIndex) {
case PKG_FORGET: {
- char *keyString;
+ const char *keyString;
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
@@ -787,11 +803,11 @@ Tcl_PackageObjCmd(
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
+ Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ ckfree(availPtr);
}
- ckfree((char *) pkgPtr);
+ ckfree(pkgPtr);
}
break;
}
@@ -837,7 +853,7 @@ Tcl_PackageObjCmd(
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
return TCL_OK;
}
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
break;
}
}
@@ -847,7 +863,7 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
if (availPtr == NULL) {
- availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+ availPtr = ckalloc(sizeof(PkgAvail));
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -947,7 +963,7 @@ Tcl_PackageObjCmd(
if (objc < 3) {
requireSyntax:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-exact? package ?requirement...?");
+ "?-exact? package ?requirement ...?");
return TCL_ERROR;
}
@@ -1013,7 +1029,7 @@ Tcl_PackageObjCmd(
break;
}
case PKG_PREFER: {
- static const char *pkgPreferOptions[] = {
+ static const char *const pkgPreferOptions[] = {
"latest", "stable", NULL
};
@@ -1098,7 +1114,7 @@ Tcl_PackageObjCmd(
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
- "version requirement requirement...");
+ "version ?requirement ...?");
return TCL_ERROR;
}
@@ -1152,7 +1168,7 @@ FindPackage(
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
- pkgPtr = (Package *) ckalloc(sizeof(Package));
+ pkgPtr = ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
@@ -1198,11 +1214,11 @@ TclFreePackageInfo(
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
+ Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ ckfree(availPtr);
}
- ckfree((char *) pkgPtr);
+ ckfree(pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
@@ -1326,6 +1342,7 @@ CheckVersionAndConvert(
ckfree(ibuf);
Tcl_AppendResult(interp, "expected version number but got \"", string,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
@@ -1588,6 +1605,7 @@ CheckRequirement(
Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
string, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
return TCL_ERROR;
}
@@ -1643,7 +1661,7 @@ AddRequirementsToResult(
for (i = 0; i < reqc; i++) {
int length;
- char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ const char *v = Tcl_GetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c
index 4eed372..5907a03 100644
--- a/generic/tclPkgConfig.c
+++ b/generic/tclPkgConfig.c
@@ -88,7 +88,7 @@
# define CFG_PROFILED "0"
#endif
-static Tcl_Config cfg[] = {
+static Tcl_Config const cfg[] = {
{"debug", CFG_DEBUG},
{"threaded", CFG_THREADED},
{"profiled", CFG_PROFILED},
@@ -120,7 +120,7 @@ static Tcl_Config cfg[] = {
void
TclInitEmbeddedConfigurationInformation(
- Tcl_Interp* interp) /* Interpreter the configuration command is
+ Tcl_Interp *interp) /* Interpreter the configuration command is
* registered in. */
{
Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING);
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index ccb8c8f..77678be 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -22,19 +22,22 @@
#endif
/*
- * Pull in the typedef of TCHAR for windows.
+ * WARNING: This file is automatically generated by the tools/genStubs.tcl
+ * script. Any modifications to the function declarations below should be made
+ * in the generic/tcl.decls script.
*/
-#if defined(__WIN32__) && !defined(_TCHAR_DEFINED)
-# include <tchar.h>
-# ifndef _TCHAR_DEFINED
- /* Borland seems to forget to set this. */
- typedef _TCHAR TCHAR;
-# define _TCHAR_DEFINED
-# endif
-# if defined(_MSC_VER) && defined(__STDC__)
- /* VS2005 SP1 misses this. See [Bug #3110161] */
- typedef _TCHAR TCHAR;
+
+/*
+ * TCHAR is needed here for win32, so if it is not defined yet do it here.
+ * This way, we don't need to include <tchar.h> just for one define.
+ */
+#if defined(_WIN32) && !defined(_TCHAR_DEFINED)
+# if defined(_UNICODE)
+ typedef wchar_t TCHAR;
+# else
+ typedef char TCHAR;
# endif
+# define _TCHAR_DEFINED
#endif
/* !BEGIN!: Do not edit below this line. */
@@ -44,88 +47,68 @@
*/
#ifdef __WIN32__ /* WIN */
-#ifndef Tcl_WinUtfToTChar_TCL_DECLARED
-#define Tcl_WinUtfToTChar_TCL_DECLARED
/* 0 */
-EXTERN TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len,
+EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
Tcl_DString *dsPtr);
-#endif
-#ifndef Tcl_WinTCharToUtf_TCL_DECLARED
-#define Tcl_WinTCharToUtf_TCL_DECLARED
/* 1 */
-EXTERN char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len,
+EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
Tcl_DString *dsPtr);
-#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_MacOSXOpenBundleResources_TCL_DECLARED
-#define Tcl_MacOSXOpenBundleResources_TCL_DECLARED
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- CONST char *bundleName, int hasResourceFile,
+ const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath);
-#endif
-#ifndef Tcl_MacOSXOpenVersionedBundleResources_TCL_DECLARED
-#define Tcl_MacOSXOpenVersionedBundleResources_TCL_DECLARED
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
- Tcl_Interp *interp, CONST char *bundleName,
- CONST char *bundleVersion,
+ Tcl_Interp *interp, const char *bundleName,
+ const char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath);
-#endif
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
- struct TclPlatStubHooks *hooks;
+ const struct TclPlatStubHooks *hooks;
#ifdef __WIN32__ /* WIN */
- TCHAR * (*tcl_WinUtfToTChar) (CONST char *str, int len, Tcl_DString *dsPtr); /* 0 */
- char * (*tcl_WinTCharToUtf) (CONST TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
+ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
+ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
+ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
+ int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
-extern TclPlatStubs *tclPlatStubsPtr;
+extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
#endif
-#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#ifdef __WIN32__ /* WIN */
-#ifndef Tcl_WinUtfToTChar
#define Tcl_WinUtfToTChar \
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
-#endif
-#ifndef Tcl_WinTCharToUtf
#define Tcl_WinTCharToUtf \
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
-#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#ifndef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
-#endif
-#ifndef Tcl_MacOSXOpenVersionedBundleResources
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#endif
#endif /* MACOSX */
-#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index d56a3bf..b722336 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -31,7 +31,7 @@
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_ErrnoId(void)
{
switch (errno) {
@@ -74,6 +74,9 @@ Tcl_ErrnoId(void)
#ifdef EBADMSG
case EBADMSG: return "EBADMSG";
#endif
+#ifdef ECANCELED
+ case ECANCELED: return "ECANCELED";
+#endif
#ifdef EBADR
case EBADR: return "EBADR";
#endif
@@ -269,7 +272,7 @@ Tcl_ErrnoId(void)
#ifdef ENOLCK
case ENOLCK: return "ENOLCK";
#endif
-#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK))
+#ifdef ENOLINK
case ENOLINK: return "ENOLINK";
#endif
#ifdef ENOMEM
@@ -284,7 +287,7 @@ Tcl_ErrnoId(void)
#ifdef ENOPKG
case ENOPKG: return "ENOPKG";
#endif
-#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT))
+#ifdef ENOPROTOOPT
case ENOPROTOOPT: return "ENOPROTOOPT";
#endif
#ifdef ENOSPC
@@ -308,6 +311,9 @@ Tcl_ErrnoId(void)
#ifdef ENOTCONN
case ENOTCONN: return "ENOTCONN";
#endif
+#ifdef ENOTRECOVERABLE
+ case ENOTRECOVERABLE: return "ENOTRECOVERABLE";
+#endif
#ifdef ENOTDIR
case ENOTDIR: return "ENOTDIR";
#endif
@@ -335,9 +341,15 @@ Tcl_ErrnoId(void)
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
+#ifdef EOTHER
+ case EOTHER: return "EOTHER";
+#endif
#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL))
case EOVERFLOW: return "EOVERFLOW";
#endif
+#ifdef EOWNERDEAD
+ case EOWNERDEAD: return "EOWNERDEAD";
+#endif
#ifdef EPERM
case EPERM: return "EPERM";
#endif
@@ -477,7 +489,7 @@ Tcl_ErrnoId(void)
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_ErrnoMsg(
int err) /* Error number (such as in errno variable). */
{
@@ -492,13 +504,13 @@ Tcl_ErrnoMsg(
case EADDRINUSE: return "address already in use";
#endif
#ifdef EADDRNOTAVAIL
- case EADDRNOTAVAIL: return "can't assign requested address";
+ case EADDRNOTAVAIL: return "cannot assign requested address";
#endif
#ifdef EADV
case EADV: return "advertise error";
#endif
#ifdef EAFNOSUPPORT
- case EAFNOSUPPORT: return "address family not supported by protocol family";
+ case EAFNOSUPPORT: return "address family not supported by protocol";
#endif
#ifdef EAGAIN
case EAGAIN: return "resource temporarily unavailable";
@@ -521,6 +533,9 @@ Tcl_ErrnoMsg(
#ifdef EBADMSG
case EBADMSG: return "not a data message";
#endif
+#ifdef ECANCELED
+ case ECANCELED: return "operation canceled";
+#endif
#ifdef EBADR
case EBADR: return "bad request descriptor";
#endif
@@ -639,13 +654,13 @@ Tcl_ErrnoMsg(
case EL3RST: return "level 3 reset";
#endif
#ifdef ELIBACC
- case ELIBACC: return "can not access a needed shared library";
+ case ELIBACC: return "cannot access a needed shared library";
#endif
#ifdef ELIBBAD
case ELIBBAD: return "accessing a corrupted shared library";
#endif
#ifdef ELIBEXEC
- case ELIBEXEC: return "can not exec a shared library directly";
+ case ELIBEXEC: return "cannot exec a shared library directly";
#endif
#ifdef ELIBMAX
case ELIBMAX: return
@@ -717,7 +732,7 @@ Tcl_ErrnoMsg(
#ifdef ENOLCK
case ENOLCK: return "no locks available";
#endif
-#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK))
+#ifdef ENOLINK
case ENOLINK: return "link has been severed";
#endif
#ifdef ENOMEM
@@ -732,7 +747,7 @@ Tcl_ErrnoMsg(
#ifdef ENOPKG
case ENOPKG: return "package not installed";
#endif
-#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT))
+#ifdef ENOPROTOOPT
case ENOPROTOOPT: return "bad protocol option";
#endif
#ifdef ENOSPC
@@ -756,6 +771,9 @@ Tcl_ErrnoMsg(
#ifdef ENOTCONN
case ENOTCONN: return "socket is not connected";
#endif
+#ifdef ENOTRECOVERABLE
+ case ENOTRECOVERABLE: return "state not recoverable";
+#endif
#ifdef ENOTDIR
case ENOTDIR: return "not a directory";
#endif
@@ -783,9 +801,15 @@ Tcl_ErrnoMsg(
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "operation not supported on socket";
#endif
+#ifdef EOTHER
+ case EOTHER: return "other error";
+#endif
#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL))
case EOVERFLOW: return "file too big";
#endif
+#ifdef EOWNERDEAD
+ case EOWNERDEAD: return "owner died";
+#endif
#ifdef EPERM
case EPERM: return "not owner";
#endif
@@ -847,7 +871,7 @@ Tcl_ErrnoMsg(
case ERREMOTE: return "object is remote";
#endif
#ifdef ESHUTDOWN
- case ESHUTDOWN: return "can't send after socket shutdown";
+ case ESHUTDOWN: return "cannot send after socket shutdown";
#endif
#ifdef ESOCKTNOSUPPORT
case ESOCKTNOSUPPORT: return "socket type not supported";
@@ -874,7 +898,7 @@ Tcl_ErrnoMsg(
case ETIMEDOUT: return "connection timed out";
#endif
#ifdef ETOOMANYREFS
- case ETOOMANYREFS: return "too many references: can't splice";
+ case ETOOMANYREFS: return "too many references: cannot splice";
#endif
#ifdef ETXTBSY
case ETXTBSY: return "text file or pseudo-device busy";
@@ -927,7 +951,7 @@ Tcl_ErrnoMsg(
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_SignalId(
int sig) /* Number of signal. */
{
@@ -1061,7 +1085,7 @@ Tcl_SignalId(
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_SignalMsg(
int sig) /* Number of signal. */
{
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index 0dc669c..cbd7b63 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -89,10 +89,10 @@ TclFinalizePreserve(void)
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
- ckfree((char *) refArray);
- refArray = NULL;
- inUse = 0;
- spaceAvl = 0;
+ ckfree(refArray);
+ refArray = NULL;
+ inUse = 0;
+ spaceAvl = 0;
}
Tcl_MutexUnlock(&preserveMutex);
}
@@ -144,8 +144,7 @@ Tcl_Preserve(
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
- refArray = (Reference *) ckrealloc((char *) refArray,
- spaceAvl * sizeof(Reference));
+ refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference));
}
/*
@@ -225,9 +224,9 @@ Tcl_Release(
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
- ckfree((char *) clientData);
+ ckfree(clientData);
} else {
- (*freeProc)((char *) clientData);
+ freeProc(clientData);
}
}
return;
@@ -238,7 +237,7 @@ Tcl_Release(
* Reference not found. This is a bug in the caller.
*/
- Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", PTR2UINT(clientData));
+ Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData);
}
/*
@@ -278,13 +277,12 @@ Tcl_EventuallyFree(
continue;
}
if (refPtr->mustFree) {
- Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x",
- PTR2UINT(clientData));
- }
- refPtr->mustFree = 1;
+ Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData);
+ }
+ refPtr->mustFree = 1;
refPtr->freeProc = freeProc;
Tcl_MutexUnlock(&preserveMutex);
- return;
+ return;
}
Tcl_MutexUnlock(&preserveMutex);
@@ -293,9 +291,9 @@ Tcl_EventuallyFree(
*/
if (freeProc == TCL_DYNAMIC) {
- ckfree((char *) clientData);
+ ckfree(clientData);
} else {
- (*freeProc)((char *)clientData);
+ freeProc(clientData);
}
}
@@ -329,9 +327,8 @@ TclHandleCreate(
* be tracked for deletion. Must not be
* NULL. */
{
- HandleStruct *handlePtr;
+ HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct));
- handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
handlePtr->ptr2 = ptr;
@@ -380,7 +377,7 @@ TclHandleFree(
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
- ckfree((char *) handlePtr);
+ ckfree(handlePtr);
}
}
@@ -464,7 +461,7 @@ TclHandleRelease(
#endif
handlePtr->refCount--;
if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
- ckfree((char *) handlePtr);
+ ckfree(handlePtr);
}
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 89bd0b9..a2de765 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -15,6 +15,18 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include "tclOOInt.h"
+
+/*
+ * Variables that are part of the [apply] command implementation and which
+ * have to be passed to the other side of the NRE call.
+ */
+
+typedef struct {
+ int isRootEnsemble;
+ Command cmd;
+ ExtraFrameInfo efi;
+} ApplyExtraData;
/*
* Prototypes for static functions in this file
@@ -27,29 +39,29 @@ static int InitArgsAndLocals(Tcl_Interp *interp,
Tcl_Obj *procNameObj, int skip);
static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
- Namespace *nsPtr);
-static void InitLocalCache(Proc *procPtr);
+ Namespace *nsPtr);
+static void InitLocalCache(Proc *procPtr);
static int PushProcCallFrame(ClientData clientData,
register Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], int isLambda);
+ Tcl_Obj *const objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
-static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
+static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
static void MakeProcError(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static void MakeLambdaError(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
- Tcl_Obj *bodyPtr, Namespace *nsPtr,
- CONST char *description, CONST char *procName,
- Proc **procPtrPtr);
+
+static Tcl_NRPostProc ApplyNR2;
+static Tcl_NRPostProc InterpProcNR2;
+static Tcl_NRPostProc Uplevel_Callback;
/*
* The ProcBodyObjType type
*/
-Tcl_ObjType tclProcBodyType = {
+const Tcl_ObjType tclProcBodyType = {
"procbody", /* name for this type */
ProcBodyFree, /* FreeInternalRep function */
ProcBodyDup, /* DupInternalRep function */
@@ -61,15 +73,15 @@ Tcl_ObjType tclProcBodyType = {
};
/*
- * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field,
- * encoding the type of level reference in ptr1 and the actual parsed out
- * offset in ptr2.
+ * The [upvar]/[uplevel] level reference type. Uses the ptrAndLongRep field,
+ * encoding the type of level reference in ptr and the actual parsed out
+ * offset in value.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
*/
-static Tcl_ObjType levelReferenceType = {
+static const Tcl_ObjType levelReferenceType = {
"levelReference",
NULL, NULL, NULL, NULL
};
@@ -83,7 +95,7 @@ static Tcl_ObjType levelReferenceType = {
* will execute within.
*/
-static Tcl_ObjType lambdaType = {
+static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
@@ -114,12 +126,12 @@ Tcl_ProcObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- char *fullName;
- CONST char *procName, *procArgs, *procBody;
+ const char *fullName;
+ const char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
@@ -142,11 +154,13 @@ Tcl_ProcObjCmd(
if (nsPtr == NULL) {
Tcl_AppendResult(interp, "can't create procedure \"", fullName,
"\": unknown namespace", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
Tcl_AppendResult(interp, "can't create procedure \"", fullName,
"\": bad procedure name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
@@ -154,6 +168,7 @@ Tcl_ProcObjCmd(
Tcl_AppendResult(interp, "can't create procedure \"", procName,
"\" in non-global namespace with name starting with \":\"",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -183,9 +198,8 @@ Tcl_ProcObjCmd(
}
Tcl_DStringAppend(&ds, procName, -1);
- cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
- TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
-
+ cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
+ TclNRInterpProc, procPtr, TclProcDeleteProc);
Tcl_DStringFree(&ds);
/*
@@ -211,11 +225,9 @@ Tcl_ProcObjCmd(
*/
if (iPtr->cmdFramePtr) {
- CmdFrame *contextPtr;
+ CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
- contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
-
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve source information from the bytecode, if possible. If
@@ -243,12 +255,12 @@ Tcl_ProcObjCmd(
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
- Tcl_HashEntry* hePtr;
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hePtr;
+ CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line = ckalloc(sizeof(int));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -260,31 +272,32 @@ Tcl_ProcObjCmd(
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
- hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew);
+ hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+ procPtr, &isNew);
if (!isNew) {
/*
- * Get the old command frame and release it. See also
+ * Get the old command frame and release it. See also
* TclProcCleanupProc in this file. Currently it seems as
* if only the procbodytest::proc command of the testsuite
* is able to trigger this situation.
*/
- CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
+ CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
- ckfree((char *) cfOldPtr->line);
+ ckfree(cfOldPtr->line);
cfOldPtr->line = NULL;
- ckfree((char *) cfOldPtr);
+ ckfree(cfOldPtr);
}
Tcl_SetHashValue(hePtr, cfPtr);
}
/*
- * 'contextPtr' is going out of scope; account for the reference that
- * it's holding to the path name.
+ * 'contextPtr' is going out of scope; account for the reference
+ * that it's holding to the path name.
*/
Tcl_DecrRefCount(contextPtr->data.eval.path);
@@ -378,17 +391,17 @@ int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
Namespace *nsPtr, /* Namespace containing this proc. */
- CONST char *procName, /* Unqualified name of this proc. */
+ const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
- CONST char **argArray = NULL;
+ const char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
- CONST char *args, *bytes, *p;
+ const char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
@@ -427,7 +440,7 @@ TclCreateProc(
*/
if (Tcl_IsShared(bodyPtr)) {
- Tcl_Obj* sharedBodyPtr = bodyPtr;
+ Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
@@ -438,7 +451,7 @@ TclCreateProc(
* not lost and applies to the new body as well.
*/
- TclContinuationsCopy (bodyPtr, sharedBodyPtr);
+ TclContinuationsCopy(bodyPtr, sharedBodyPtr);
}
/*
@@ -449,7 +462,7 @@ TclCreateProc(
Tcl_IncrRefCount(bodyPtr);
- procPtr = (Proc *) ckalloc(sizeof(Proc));
+ procPtr = ckalloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
procPtr->bodyPtr = bodyPtr;
@@ -480,6 +493,8 @@ TclCreateProc(
"procedure \"%s\": arg list contains %d entries, "
"precompiled header expects %d", procName, numArgs,
procPtr->numArgs));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
@@ -490,7 +505,7 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
- CONST char **fieldValues;
+ const char **fieldValues;
/*
* Now divide the specifier up into name and default.
@@ -502,15 +517,19 @@ TclCreateProc(
goto procError;
}
if (fieldCount > 2) {
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
Tcl_AppendResult(interp,
"too many fields in argument specifier \"",
argArray[i], "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
Tcl_AppendResult(interp, "argument with no name", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
@@ -528,23 +547,25 @@ TclCreateProc(
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
- CONST char *q = p;
+ const char *q = p;
do {
q++;
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0],
- "\" is an array element", NULL);
- ckfree((char *) fieldValues);
+ fieldValues[0], "\" is an array element", NULL);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0],
- "\" is not a simple name", NULL);
- ckfree((char *) fieldValues);
+ fieldValues[0], "\" is not a simple name", NULL);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
p++;
@@ -571,7 +592,9 @@ TclCreateProc(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
@@ -581,7 +604,7 @@ TclCreateProc(
if (localPtr->defValuePtr != NULL) {
int tmpLength;
- char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
+ const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
&tmpLength);
if ((valueLength != tmpLength) ||
@@ -590,7 +613,9 @@ TclCreateProc(
"procedure \"%s\": formal parameter \"%s\" has "
"default value inconsistent with precompiled body",
procName, fieldValues[0]));
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
}
@@ -608,9 +633,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = (CompiledLocal *) ckalloc((unsigned)
- (sizeof(CompiledLocal) - sizeof(localPtr->name)
- + nameLength + 1));
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -639,11 +662,11 @@ TclCreateProc(
}
}
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree((char *) argArray);
+ ckfree(argArray);
return TCL_OK;
procError:
@@ -660,12 +683,12 @@ TclCreateProc(
Tcl_DecrRefCount(defPtr);
}
- ckfree((char *) localPtr);
+ ckfree(localPtr);
}
- ckfree((char *) procPtr);
+ ckfree(procPtr);
}
if (argArray != NULL) {
- ckfree((char *) argArray);
+ ckfree(argArray);
}
return TCL_ERROR;
}
@@ -698,7 +721,7 @@ TclCreateProc(
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
- CONST char *name, /* String describing frame. */
+ const char *name, /* String describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
@@ -746,6 +769,7 @@ TclGetFrame(
levelError:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -784,7 +808,7 @@ TclObjGetFrame(
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- CONST char *name = TclGetString(objPtr);
+ const char *name;
/*
* Parse object to figure out which level number to go to.
@@ -792,11 +816,17 @@ TclObjGetFrame(
result = 1;
curLevel = iPtr->varFramePtr->level;
+ if (objPtr == NULL) {
+ name = "1";
+ goto haveLevel1;
+ }
+
+ name = TclGetString(objPtr);
if (objPtr->typePtr == &levelReferenceType) {
- if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) {
- level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
+ if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) {
+ level = curLevel - objPtr->internalRep.ptrAndLongRep.value;
} else {
- level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
+ level = objPtr->internalRep.ptrAndLongRep.value;
}
if (level < 0) {
goto levelError;
@@ -824,8 +854,8 @@ TclObjGetFrame(
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
+ objPtr->internalRep.ptrAndLongRep.ptr = NULL;
+ objPtr->internalRep.ptrAndLongRep.value = level;
} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
return -1;
@@ -839,14 +869,16 @@ TclObjGetFrame(
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
+ objPtr->internalRep.ptrAndLongRep.ptr = (void *) 1; /* non-NULL */
+ objPtr->internalRep.ptrAndLongRep.value = level;
level = curLevel - level;
} else {
/*
- * Don't cache as the object *isn't* a level reference.
+ * Don't cache as the object *isn't* a level reference (might even be
+ * NULL...)
*/
+ haveLevel1:
level = curLevel - 1;
result = 0;
}
@@ -870,6 +902,7 @@ TclObjGetFrame(
levelError:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -890,17 +923,52 @@ TclObjGetFrame(
*----------------------------------------------------------------------
*/
+static int
+Uplevel_Callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallFrame *savedVarFramePtr = data[0];
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
+ }
+
+ /*
+ * Restore the variable frame, and return.
+ */
+
+ ((Interp *)interp)->varFramePtr = savedVarFramePtr;
+ return result;
+}
+
/* ARGSUSED */
int
Tcl_UplevelObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRUplevelObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
+
register Interp *iPtr = (Interp *) interp;
+ CmdFrame *invoker = NULL;
+ int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
+ Tcl_Obj *objPtr;
if (objc < 2) {
uplevelSyntax:
@@ -916,11 +984,11 @@ Tcl_UplevelObjCmd(
if (result == -1) {
return TCL_ERROR;
}
- objc -= (result+1);
+ objc -= result + 1;
if (objc == 0) {
goto uplevelSyntax;
}
- objv += (result+1);
+ objv += result + 1;
/*
* Modify the interpreter state to execute in the given frame.
@@ -935,14 +1003,12 @@ Tcl_UplevelObjCmd(
if (objc == 1) {
/*
- * TIP #280. Make argument location available to eval'd script
+ * TIP #280. Make actual argument location available to eval'd script
*/
- CmdFrame* invoker = NULL;
- int word = 0;
+ TclArgumentGet(interp, objv[0], &invoker, &word);
+ objPtr = objv[0];
- TclArgumentGet (interp, objv[0], &invoker, &word);
- result = TclEvalObjEx(interp, objv[0], 0, invoker, word);
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -950,22 +1016,12 @@ Tcl_UplevelObjCmd(
* object when it decrements its refcount after eval'ing it.
*/
- Tcl_Obj *objPtr;
-
objPtr = Tcl_ConcatObj(objc, objv);
- result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
- }
- if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"uplevel\" body line %d)", interp->errorLine));
}
- /*
- * Restore the variable frame, and return.
- */
-
- iPtr->varFramePtr = savedVarFramePtr;
- return result;
+ TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
+ NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
/*
@@ -994,10 +1050,9 @@ Tcl_UplevelObjCmd(
Proc *
TclFindProc(
Interp *iPtr, /* Interpreter in which to look. */
- CONST char *procName) /* Name of desired procedure. */
+ const char *procName) /* Name of desired procedure. */
{
Tcl_Command cmd;
- Tcl_Command origCmd;
Command *cmdPtr;
cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
@@ -1006,14 +1061,7 @@ TclFindProc(
}
cmdPtr = (Command *) cmd;
- origCmd = TclGetOriginalCommand(cmd);
- if (origCmd != NULL) {
- cmdPtr = (Command *) origCmd;
- }
- if (cmdPtr->objProc != TclObjInterpProc) {
- return NULL;
- }
- return (Proc *) cmdPtr->objClientData;
+ return TclIsProc(cmdPtr);
}
/*
@@ -1038,41 +1086,21 @@ Proc *
TclIsProc(
Command *cmdPtr) /* Command to test. */
{
- Tcl_Command origCmd;
+ Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
- origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
- if (cmdPtr->objProc == TclObjInterpProc) {
- return (Proc *) cmdPtr->objClientData;
+ if (cmdPtr->deleteProc == TclProcDeleteProc) {
+ return cmdPtr->objClientData;
}
- return (Proc *) 0;
+ return NULL;
}
-/*
- *----------------------------------------------------------------------
- *
- * InitArgsAndLocals --
- *
- * This routine is invoked in order to initialize the arguments and other
- * compiled locals table for a new call frame.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Allocates memory on the stack for the compiled local variables, the
- * caller is responsible for freeing them. Initialises all variables. May
- * invoke various name resolvers in order to determine which variables
- * are being referenced at runtime.
- *
- *----------------------------------------------------------------------
- */
-
static int
ProcWrongNumArgs(
- Tcl_Interp *interp, int skip)
+ Tcl_Interp *interp,
+ int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
@@ -1086,7 +1114,7 @@ ProcWrongNumArgs(
*/
numArgs = framePtr->procPtr->numArgs;
- desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
+ desiredObjs = TclStackAlloc(interp,
(int) sizeof(Tcl_Obj *) * (numArgs+1));
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
@@ -1110,7 +1138,7 @@ ProcWrongNumArgs(
Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
} else if (defPtr->flags & VAR_IS_ARGS) {
numArgs--;
- final = "...";
+ final = "?arg ...?";
break;
} else {
argObj = namePtr;
@@ -1140,7 +1168,6 @@ ProcWrongNumArgs(
* DEPRECATED: functionality has been inlined elsewhere; this function
* remains to insure binary compatibility with Itcl.
*
-
* Results:
* None.
*
@@ -1150,6 +1177,7 @@ ProcWrongNumArgs(
*
*----------------------------------------------------------------------
*/
+
void
TclInitCompiledLocals(
Tcl_Interp *interp, /* Current interpreter. */
@@ -1219,37 +1247,7 @@ InitResolvedLocals(
}
if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
- /*
- * Initialize the array of local variables stored in the call frame.
- * Some variables may have special resolution rules. In that case, we
- * call their "resolver" procs to get our hands on the variable, and
- * we make the compiled local a link to the real variable.
- */
-
- doInitResolvedLocals:
- for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
- varPtr->flags = 0;
- varPtr->value.objPtr = NULL;
-
- /*
- * Now invoke the resolvers to determine the exact variables
- * that should be used.
- */
-
- resVarInfo = localPtr->resolveInfo;
- if (resVarInfo && resVarInfo->fetchProc) {
- Var *resolvedVarPtr = (Var *)
- (*resVarInfo->fetchProc)(interp, resVarInfo);
- if (resolvedVarPtr) {
- if (TclIsVarInHash(resolvedVarPtr)) {
- VarHashRefCount(resolvedVarPtr)++;
- }
- varPtr->flags = VAR_LINK;
- varPtr->value.linkPtr = resolvedVarPtr;
- }
- }
- }
- return;
+ goto doInitResolvedLocals;
}
/*
@@ -1263,7 +1261,7 @@ InitResolvedLocals(
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
- ckfree((char *) localPtr->resolveInfo);
+ ckfree(localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
@@ -1276,7 +1274,7 @@ InitResolvedLocals(
int result;
if (nsPtr->compiledVarResProc) {
- result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
+ result = nsPtr->compiledVarResProc(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
} else {
@@ -1285,7 +1283,7 @@ InitResolvedLocals(
while ((result == TCL_CONTINUE) && resPtr) {
if (resPtr->compiledVarResProc) {
- result = (*resPtr->compiledVarResProc)(nsPtr->interp,
+ result = resPtr->compiledVarResProc(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
}
@@ -1299,9 +1297,40 @@ InitResolvedLocals(
}
localPtr = firstLocalPtr;
codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
- goto doInitResolvedLocals;
-}
+ /*
+ * Initialize the array of local variables stored in the call frame. Some
+ * variables may have special resolution rules. In that case, we call
+ * their "resolver" procs to get our hands on the variable, and we make
+ * the compiled local a link to the real variable.
+ */
+
+ doInitResolvedLocals:
+ for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
+ varPtr->flags = 0;
+ varPtr->value.objPtr = NULL;
+
+ /*
+ * Now invoke the resolvers to determine the exact variables that
+ * should be used.
+ */
+
+ resVarInfo = localPtr->resolveInfo;
+ if (resVarInfo && resVarInfo->fetchProc) {
+ register Var *resolvedVarPtr = (Var *)
+ resVarInfo->fetchProc(interp, resVarInfo);
+
+ if (resolvedVarPtr) {
+ if (TclIsVarInHash(resolvedVarPtr)) {
+ VarHashRefCount(resolvedVarPtr)++;
+ }
+ varPtr->flags = VAR_LINK;
+ varPtr->value.linkPtr = resolvedVarPtr;
+ }
+ }
+ }
+}
+
void
TclFreeLocalCache(
Tcl_Interp *interp,
@@ -1311,12 +1340,13 @@ TclFreeLocalCache(
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
- Tcl_Obj *objPtr = *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.
+ * 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);
@@ -1325,11 +1355,12 @@ TclFreeLocalCache(
}
}
}
- ckfree((char *) localCachePtr);
+ ckfree(localCachePtr);
}
-
+
static void
-InitLocalCache(Proc *procPtr)
+InitLocalCache(
+ Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
@@ -1348,9 +1379,9 @@ InitLocalCache(Proc *procPtr)
* for future calls.
*/
- localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
- + (localCt-1)*sizeof(Tcl_Obj *)
- + numArgs*sizeof(Var));
+ localCachePtr = ckalloc(sizeof(LocalCache)
+ + (localCt - 1) * sizeof(Tcl_Obj *)
+ + numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
@@ -1372,12 +1403,32 @@ InitLocalCache(Proc *procPtr)
i++;
}
namePtr++;
- localPtr=localPtr->nextPtr;
+ localPtr = localPtr->nextPtr;
}
codePtr->localCachePtr = localCachePtr;
localCachePtr->refCount = 1;
- localCachePtr->numVars = localCt;
+ localCachePtr->numVars = localCt;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitArgsAndLocals --
+ *
+ * This routine is invoked in order to initialize the arguments and other
+ * compiled locals table for a new call frame.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Allocates memory on the stack for the compiled local variables, the
+ * caller is responsible for freeing them. Initialises all variables. May
+ * invoke various name resolvers in order to determine which variables
+ * are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
static int
InitArgsAndLocals(
@@ -1416,7 +1467,7 @@ InitArgsAndLocals(
* parameters.
*/
- varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
+ varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var)));
framePtr->compiledLocals = varPtr;
framePtr->numCompiledLocals = localCt;
@@ -1439,7 +1490,7 @@ InitArgsAndLocals(
}
}
imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
- for (i = 0; i < imax; i++, varPtr++, defPtr++) {
+ for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
/*
* "Normal" arguments; last formal is special, depends on it being
* 'args'.
@@ -1451,21 +1502,20 @@ InitArgsAndLocals(
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
}
- for (; i < numArgs-1; i++, varPtr++, defPtr++) {
+ for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
/*
* This loop is entered if argCt < (numArgs-1). Set default values;
* last formal is special.
*/
- Tcl_Obj *objPtr = defPtr->value.objPtr;
+ Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL;
- if (objPtr) {
- varPtr->flags = 0;
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var reference. */
- } else {
+ if (!objPtr) {
goto incorrectArgs;
}
+ varPtr->flags = 0;
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var reference. */
}
/*
@@ -1473,9 +1523,8 @@ InitArgsAndLocals(
* defPtr and varPtr point to the last argument to be initialized.
*/
-
varPtr->flags = 0;
- if (defPtr->flags & VAR_IS_ARGS) {
+ if (defPtr && defPtr->flags & VAR_IS_ARGS) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
varPtr->value.objPtr = listPtr;
@@ -1485,7 +1534,7 @@ InitArgsAndLocals(
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) {
+ } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) {
Tcl_Obj *objPtr = defPtr->value.objPtr;
varPtr->value.objPtr = objPtr;
@@ -1502,7 +1551,8 @@ InitArgsAndLocals(
correctArgs:
if (numArgs < localCt) {
- if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) {
+ if (!framePtr->nsPtr->compiledVarResProc
+ && !((Interp *)interp)->resolverPtr) {
memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
} else {
InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
@@ -1511,13 +1561,13 @@ InitArgsAndLocals(
return TCL_OK;
-
- incorrectArgs:
/*
* Initialise all compiled locals to avoid problems at DeleteLocalVars.
*/
- memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var));
+ incorrectArgs:
+ memset(varPtr, 0,
+ ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
return ProcWrongNumArgs(interp, skip);
}
@@ -1541,17 +1591,17 @@ InitArgsAndLocals(
static int
PushProcCallFrame(
- ClientData clientData, /* Record describing procedure to be
+ ClientData clientData, /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *CONST objv[], /* Argument value objects. */
+ Tcl_Obj *const objv[], /* Argument value objects. */
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
{
- Proc *procPtr = (Proc *) clientData;
+ Proc *procPtr = clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
@@ -1578,7 +1628,7 @@ PushProcCallFrame(
*/
codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
- if (((Interp *) *codePtr->interpHandle != iPtr)
+ if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
@@ -1586,9 +1636,9 @@ PushProcCallFrame(
}
} else {
doCompilation:
- result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
(isLambda ? "body of lambda term" : "body of proc"),
- TclGetString(objv[isLambda]), &procPtr);
+ TclGetString(objv[isLambda]));
if (result != TCL_OK) {
return result;
}
@@ -1636,28 +1686,44 @@ PushProcCallFrame(
int
TclObjInterpProc(
- ClientData clientData, /* Record describing procedure to be
+ ClientData clientData, /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *CONST objv[]) /* Argument value objects. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
{
- int result;
+ /*
+ * Not used much in the core; external interface for iTcl
+ */
- result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
- if (result == TCL_OK) {
- return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
- } else {
+ return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv);
+}
+
+int
+TclNRInterpProc(
+ ClientData clientData, /* Record describing procedure to be
+ * interpreted. */
+ register Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ int objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ int result = PushProcCallFrame(clientData, interp, objc, objv,
+ /*isLambda*/ 0);
+
+ if (result != TCL_OK) {
return TCL_ERROR;
}
+ return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProcCore --
+ * TclNRInterpProcCore --
*
* When a Tcl procedure, lambda term or anything else that works like a
* procedure gets invoked during bytecode evaluation, this object-based
@@ -1673,23 +1739,29 @@ TclObjInterpProc(
*/
int
-TclObjInterpProcCore(
+TclNRInterpProcCore(
register Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
int skip, /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
- ProcErrorProc errorProc) /* How to convert results from the script into
+ ProcErrorProc *errorProc) /* How to convert results from the script into
* results of the overall procedure. */
{
Interp *iPtr = (Interp *) interp;
register Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
+ ByteCode *codePtr;
result = InitArgsAndLocals(interp, procNameObj, skip);
if (result != TCL_OK) {
- goto procDone;
+ freePtr = iPtr->framePtr;
+ Tcl_PopCallFrame(interp); /* Pop but do not free. */
+ TclStackFree(interp, freePtr->compiledLocals);
+ /* Free compiledLocals. */
+ TclStackFree(interp, freePtr); /* Free CallFrame. */
+ return TCL_ERROR;
}
#if defined(TCL_COMPILE_DEBUG)
@@ -1713,25 +1785,42 @@ TclObjInterpProcCore(
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
- char *a[10];
- int i = 0;
int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ const char *a[10];
+ int i;
- while (i < 10) {
+ for (i = 0 ; i < 10 ; i++) {
a[i] = (l < iPtr->varFramePtr->objc ?
- TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++;
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL);
+ l++;
}
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
- char *a[4]; int i[2];
+ const char *a[6]; int i[2];
TclDTraceInfo(info, a, i);
- TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]);
+ TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
TclDecrRefCount(info);
}
+ if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+ TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
+ iPtr->varFramePtr->objc - l - 1,
+ (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
+ }
+ if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+ TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
+ iPtr->varFramePtr->objc - l - 1,
+ (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
+ }
#endif /* USE_DTRACE */
/*
@@ -1739,38 +1828,32 @@ TclObjInterpProcCore(
*/
procPtr->refCount++;
- iPtr->numLevels++;
+ codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
- if (TclInterpReady(interp) == TCL_ERROR) {
- result = TCL_ERROR;
- } else {
- register ByteCode *codePtr =
- procPtr->bodyPtr->internalRep.otherValuePtr;
+ TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
+ NULL, NULL);
+ return TclNRExecuteByteCode(interp, codePtr);
+}
- codePtr->refCount++;
-#ifdef USE_DTRACE
- if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l;
+static int
+InterpProcNR2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr = iPtr->varFramePtr->procPtr;
+ CallFrame *freePtr;
+ Tcl_Obj *procNameObj = data[0];
+ ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
- l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
- TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
- iPtr->varFramePtr->objc - l,
- (Tcl_Obj **)(iPtr->varFramePtr->objv + l));
- }
-#endif /* USE_DTRACE */
- result = TclExecuteByteCode(interp, codePtr);
- if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
- TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
- }
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
- }
+ if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
- iPtr->numLevels--;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
+ }
+ if (--procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
@@ -1798,6 +1881,7 @@ TclObjInterpProcCore(
Tcl_AppendResult(interp, "invoked \"",
((result == TCL_BREAK) ? "break" : "continue"),
"\" outside of a loop", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
/*
@@ -1811,7 +1895,7 @@ TclObjInterpProcCore(
* function handed to us as an argument.
*/
- (*errorProc)(interp, procNameObj);
+ errorProc(interp, procNameObj);
default:
/*
@@ -1828,17 +1912,15 @@ TclObjInterpProcCore(
(void) 0; /* do nothing */
}
-#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
- Tcl_Obj *r;
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Obj *r = Tcl_GetObjResult(interp);
- r = Tcl_GetObjResult(interp);
- TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result,
+ TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
TclGetString(r), r);
}
-#endif /* USE_DTRACE */
- procDone:
/*
* Free the stack-allocated compiled locals and CallFrame. It is important
* to pop the call frame without freeing it first: the compiledLocals
@@ -1852,6 +1934,7 @@ TclObjInterpProcCore(
TclStackFree(interp, freePtr->compiledLocals);
/* Free compiledLocals. */
TclStackFree(interp, freePtr); /* Free CallFrame. */
+
return result;
}
@@ -1880,34 +1963,15 @@ TclProcCompileProc(
Tcl_Interp *interp, /* Interpreter containing procedure. */
Proc *procPtr, /* Data associated with procedure. */
Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr,
- * but could be any code fragment compiled in
- * the context of this procedure.) */
- Namespace *nsPtr, /* Namespace containing procedure. */
- CONST char *description, /* string describing this body of code. */
- CONST char *procName) /* Name of this procedure. */
-{
- return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
- procName, NULL);
-}
-
-static int
-ProcCompileProc(
- Tcl_Interp *interp, /* Interpreter containing procedure. */
- Proc *procPtr, /* Data associated with procedure. */
- Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr,
- * but could be any code fragment compiled in
- * the context of this procedure.) */
+ * but could be any code fragment compiled in
+ * the context of this procedure.) */
Namespace *nsPtr, /* Namespace containing procedure. */
- CONST char *description, /* string describing this body of code. */
- CONST char *procName, /* Name of this procedure. */
- Proc **procPtrPtr) /* Points to storage where a replacement
- * (Proc *) value may be written. */
+ const char *description, /* string describing this body of code. */
+ const char *procName) /* Name of this procedure. */
{
Interp *iPtr = (Interp *) interp;
- int i;
Tcl_CallFrame *framePtr;
ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
- CompiledLocal *localPtr;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1924,35 +1988,37 @@ ProcCompileProc(
*/
if (bodyPtr->typePtr == &tclByteCodeType) {
- if (((Interp *) *codePtr->interpHandle == iPtr)
+ if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
return TCL_OK;
- } else {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- Tcl_AppendResult(interp,
- "a precompiled script jumped interps", NULL);
- return TCL_ERROR;
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- codePtr->nsPtr = nsPtr;
- } else {
- bodyPtr->typePtr->freeIntRepProc(bodyPtr);
- bodyPtr->typePtr = NULL;
+ }
+
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
+ Tcl_AppendResult(interp,
+ "a precompiled script jumped interps", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "CROSSINTERPBYTECODE", NULL);
+ return TCL_ERROR;
}
- }
+ codePtr->compileEpoch = iPtr->compileEpoch;
+ codePtr->nsPtr = nsPtr;
+ } else {
+ TclFreeIntRep(bodyPtr);
+ }
}
+
if (bodyPtr->typePtr != &tclByteCodeType) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceCompile >= 1) {
- /*
- * Display a line summarizing the top level command we are about
- * to compile.
- */
+ if (tclTraceCompile >= 1) {
+ /*
+ * Display a line summarizing the top level command we are about
+ * to compile.
+ */
Tcl_Obj *message;
@@ -1960,85 +2026,50 @@ ProcCompileProc(
Tcl_IncrRefCount(message);
Tcl_AppendStringsToObj(message, description, " \"", NULL);
Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
- fprintf(stdout, "%s\"\n", TclGetString(message));
+ fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
- }
+ }
#endif
- /*
- * Plug the current procPtr into the interpreter and coerce the code
- * body to byte codes. The interpreter needs to know which proc it's
- * compiling so that it can access its list of compiled locals.
- *
- * TRICKY NOTE: Be careful to push a call frame with the proper
- * namespace context, so that the byte codes are compiled in the
- * appropriate class context.
- */
-
- if (procPtrPtr != NULL && procPtr->refCount > 1) {
- Tcl_Command token;
- Tcl_CmdInfo info;
- Proc *newProc = (Proc *) ckalloc(sizeof(Proc));
-
- newProc->iPtr = procPtr->iPtr;
- newProc->refCount = 1;
- newProc->cmdPtr = procPtr->cmdPtr;
- token = (Tcl_Command) newProc->cmdPtr;
- newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr);
- bodyPtr = newProc->bodyPtr;
- Tcl_IncrRefCount(bodyPtr);
- newProc->numArgs = procPtr->numArgs;
-
- newProc->numCompiledLocals = newProc->numArgs;
- newProc->firstLocalPtr = NULL;
- newProc->lastLocalPtr = NULL;
- localPtr = procPtr->firstLocalPtr;
- for (i=0; i<newProc->numArgs; i++, localPtr=localPtr->nextPtr) {
- CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
- (sizeof(CompiledLocal) - sizeof(localPtr->name)
- + localPtr->nameLength + 1));
-
- if (newProc->firstLocalPtr == NULL) {
- newProc->firstLocalPtr = newProc->lastLocalPtr = copy;
- } else {
- newProc->lastLocalPtr->nextPtr = copy;
- newProc->lastLocalPtr = copy;
- }
- copy->nextPtr = NULL;
- copy->nameLength = localPtr->nameLength;
- copy->frameIndex = localPtr->frameIndex;
- copy->flags = localPtr->flags;
- copy->defValuePtr = localPtr->defValuePtr;
- if (copy->defValuePtr) {
- Tcl_IncrRefCount(copy->defValuePtr);
- }
- copy->resolveInfo = localPtr->resolveInfo;
- memcpy(copy->name, localPtr->name, localPtr->nameLength + 1);
- }
+ /*
+ * Plug the current procPtr into the interpreter and coerce the code
+ * body to byte codes. The interpreter needs to know which proc it's
+ * compiling so that it can access its list of compiled locals.
+ *
+ * TRICKY NOTE: Be careful to push a call frame with the proper
+ * namespace context, so that the byte codes are compiled in the
+ * appropriate class context.
+ */
- /*
- * Reset the ClientData
- */
+ iPtr->compiledProcPtr = procPtr;
- Tcl_GetCommandInfoFromToken(token, &info);
- if (info.objClientData == (ClientData) procPtr) {
- info.objClientData = (ClientData) newProc;
- }
- if (info.clientData == (ClientData) procPtr) {
- info.clientData = (ClientData) newProc;
+ if (procPtr->numCompiledLocals > procPtr->numArgs) {
+ CompiledLocal *clPtr = procPtr->firstLocalPtr;
+ CompiledLocal *lastPtr = NULL;
+ int i, numArgs = procPtr->numArgs;
+
+ for (i = 0; i < numArgs; i++) {
+ lastPtr = clPtr;
+ clPtr = clPtr->nextPtr;
}
- if (info.deleteData == (ClientData) procPtr) {
- info.deleteData = (ClientData) newProc;
+
+ if (lastPtr) {
+ lastPtr->nextPtr = NULL;
+ } else {
+ procPtr->firstLocalPtr = NULL;
}
- Tcl_SetCommandInfoFromToken(token, &info);
+ procPtr->lastLocalPtr = lastPtr;
+ while (clPtr) {
+ CompiledLocal *toFree = clPtr;
- procPtr->refCount--;
- *procPtrPtr = procPtr = newProc;
+ clPtr = clPtr->nextPtr;
+ ckfree(toFree);
+ }
+ procPtr->numCompiledLocals = procPtr->numArgs;
}
- iPtr->compiledProcPtr = procPtr;
- (void) TclPushStackFrame(interp, &framePtr,
- (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0);
+ TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
+ /* isProcCallFrame */ 0);
/*
* TIP #280: We get the invoking context from the cmdFrame which
@@ -2052,9 +2083,8 @@ ProcCompileProc(
*/
iPtr->invokeWord = 0;
- iPtr->invokeCmdFramePtr =
- (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL);
- (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr);
+ iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
+ tclByteCodeType.setFromAnyProc(interp, bodyPtr);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -2101,7 +2131,7 @@ MakeProcError(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
- (overflow ? "..." : ""), interp->errorLine));
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
@@ -2128,7 +2158,7 @@ void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
- Proc *procPtr = (Proc *) clientData;
+ Proc *procPtr = clientData;
procPtr->refCount--;
if (procPtr->refCount <= 0) {
@@ -2174,9 +2204,9 @@ TclProcCleanupProc(
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
if (resVarInfo->deleteProc) {
- (*resVarInfo->deleteProc)(resVarInfo);
+ resVarInfo->deleteProc(resVarInfo);
} else {
- ckfree((char *) resVarInfo);
+ ckfree(resVarInfo);
}
}
@@ -2184,16 +2214,15 @@ TclProcCleanupProc(
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
- ckfree((char *) localPtr);
+ ckfree(localPtr);
localPtr = nextPtr;
}
- ckfree((char *) procPtr);
+ ckfree(procPtr);
/*
* TIP #280: Release the location data associated with this Proc
* structure, if any. The interpreter may not exist (For example for
- * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when
- * the same ProcPtr is overwritten with a new CmdFrame.
+ * procbody structures created by tbcload.
*/
if (!iPtr) {
@@ -2205,15 +2234,15 @@ TclProcCleanupProc(
return;
}
- cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
+ cfPtr = Tcl_GetHashValue(hePtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
- ckfree((char *) cfPtr->line);
+ ckfree(cfPtr->line);
cfPtr->line = NULL;
- ckfree((char *) cfPtr);
+ ckfree(cfPtr);
Tcl_DeleteHashEntry(hePtr);
}
@@ -2443,7 +2472,7 @@ SetLambdaFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
int objc, result;
Proc *procPtr;
@@ -2463,6 +2492,7 @@ SetLambdaFromAny(
Tcl_AppendObjToObj(errPtr, objPtr);
Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
Tcl_SetObjResult(interp, errPtr);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
return TCL_ERROR;
}
@@ -2511,11 +2541,9 @@ SetLambdaFromAny(
*/
if (iPtr->cmdFramePtr) {
- CmdFrame *contextPtr;
+ CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
- contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
-
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve the source context from the bytecode. This call
@@ -2543,7 +2571,7 @@ SetLambdaFromAny(
if (contextPtr->line
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
int isNew, buf[2];
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
/*
* Move from approximation (line of list cmd word) to actual
@@ -2554,7 +2582,7 @@ SetLambdaFromAny(
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line = ckalloc(sizeof(int));
cfPtr->line[0] = buf[1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -2567,7 +2595,7 @@ SetLambdaFromAny(
cfPtr->cmd.str.len = 0;
Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- (char *) procPtr, &isNew), cfPtr);
+ procPtr, &isNew), cfPtr);
}
/*
@@ -2588,7 +2616,7 @@ SetLambdaFromAny(
if (objc == 2) {
TclNewLiteralStringObj(nsObjPtr, "::");
} else {
- char *nsName = TclGetString(objv[2]);
+ const char *nsName = TclGetString(objv[2]);
if ((*nsName != ':') || (*(nsName+1) != ':')) {
TclNewLiteralStringObj(nsObjPtr, "::");
@@ -2606,7 +2634,7 @@ SetLambdaFromAny(
* conversion to lambdaType.
*/
- objPtr->typePtr->freeIntRepProc(objPtr);
+ TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
@@ -2636,18 +2664,27 @@ Tcl_ApplyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRApplyObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result, isRootEnsemble;
- Command cmd;
Tcl_Namespace *nsPtr;
- ExtraFrameInfo efi;
+ ApplyExtraData *extraPtr;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?");
return TCL_ERROR;
}
@@ -2662,6 +2699,12 @@ Tcl_ApplyObjCmd(
}
#define JOE_EXTENSION 0
+/*
+ * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
+ * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
+ * the code. (MS)
+ */
+
#if JOE_EXTENSION
else {
/*
@@ -2688,25 +2731,6 @@ Tcl_ApplyObjCmd(
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
- memset(&cmd, 0, sizeof(Command));
- procPtr->cmdPtr = &cmd;
-
- /*
- * TIP#280 (semi-)HACK!
- *
- * Using cmd.clientData to tell [info frame] how to render the
- * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr
- * for NULL. This condition holds here because of the 'memset' above, and
- * nowhere else (in the core). Regular commands always have a valid
- * 'hPtr', and lambda's never.
- */
-
- efi.length = 1;
- efi.fields[0].name = "lambda";
- efi.fields[0].proc = NULL;
- efi.fields[0].clientData = lambdaPtr;
- cmd.clientData = &efi;
-
/*
* Find the namespace where this lambda should run, and push a call frame
* for that namespace. Note that TclObjInterpProc() will pop it.
@@ -2715,10 +2739,29 @@ Tcl_ApplyObjCmd(
nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
- return result;
+ return TCL_ERROR;
}
- cmd.nsPtr = (Namespace *) nsPtr;
+ extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+ memset(&extraPtr->cmd, 0, sizeof(Command));
+ procPtr->cmdPtr = &extraPtr->cmd;
+ extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
+
+ /*
+ * TIP#280 (semi-)HACK!
+ *
+ * Using cmd.clientData to tell [info frame] how to render the lambdaPtr.
+ * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL.
+ * This condition holds here because of the memset() above, and nowhere
+ * else (in the core). Regular commands always have a valid hPtr, and
+ * lambda's never.
+ */
+
+ extraPtr->efi.length = 1;
+ extraPtr->efi.fields[0].name = "lambda";
+ extraPtr->efi.fields[0].proc = NULL;
+ extraPtr->efi.fields[0].clientData = lambdaPtr;
+ extraPtr->cmd.clientData = &extraPtr->efi;
isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
if (isRootEnsemble) {
@@ -2728,18 +2771,29 @@ Tcl_ApplyObjCmd(
} else {
iPtr->ensembleRewrite.numInsertedObjs -= 1;
}
+ extraPtr->isRootEnsemble = isRootEnsemble;
- result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
+ result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
- result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+ TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
+ result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
}
+ return result;
+}
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
+static int
+ApplyNR2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ApplyExtraData *extraPtr = data[0];
+
+ if (extraPtr->isRootEnsemble) {
+ ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
}
+ TclStackFree(interp, extraPtr);
return result;
}
@@ -2775,10 +2829,9 @@ MakeLambdaError(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
- (overflow ? "..." : ""), interp->errorLine));
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
-
/*
*----------------------------------------------------------------------
*
@@ -2797,18 +2850,23 @@ Tcl_DisassembleObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *types[] = {
- "lambda", "proc", "script", NULL
+ static const char *const types[] = {
+ "lambda", "method", "objmethod", "proc", "script", NULL
};
enum Types {
- DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT
+ DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
+ DISAS_SCRIPT
};
int idx, result;
+ Tcl_Obj *codeObjPtr = NULL;
+ Proc *procPtr = NULL;
+ Tcl_HashEntry *hPtr;
+ Object *oPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type ...");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
@@ -2817,7 +2875,6 @@ Tcl_DisassembleObjCmd(
switch ((enum Types) idx) {
case DISAS_LAMBDA: {
- Proc *procPtr = NULL;
Command cmd;
Tcl_Obj *nsObjPtr;
Tcl_Namespace *nsPtr;
@@ -2826,6 +2883,10 @@ Tcl_DisassembleObjCmd(
* Compile (if uncompiled) and disassemble a lambda term.
*/
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
+ return TCL_ERROR;
+ }
if (objv[2]->typePtr == &lambdaType) {
procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
}
@@ -2850,21 +2911,21 @@ Tcl_DisassembleObjCmd(
return result;
}
TclPopStackFrame(interp);
- if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
- & TCL_BYTECODE_PRECOMPILED) {
- Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
- NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ codeObjPtr = procPtr->bodyPtr;
break;
}
- case DISAS_PROC: {
- Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+ case DISAS_PROC:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "procName");
+ return TCL_ERROR;
+ }
+ procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
"\" isn't a procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -2877,28 +2938,125 @@ Tcl_DisassembleObjCmd(
return result;
}
TclPopStackFrame(interp);
- if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
- & TCL_BYTECODE_PRECOMPILED) {
- Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
- NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ codeObjPtr = procPtr->bodyPtr;
break;
- }
case DISAS_SCRIPT:
/*
* Compile and disassemble a script.
*/
+ if (objc != 3) {
+ 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;
}
}
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2]));
+ codeObjPtr = objv[2];
+ break;
+
+ case DISAS_CLASS_METHOD:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of a class method.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+ "\" is not a class", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+ (char *) objv[3]);
+ goto methodBody;
+ case DISAS_OBJECT_METHOD:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of an instance method.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->methodsPtr == NULL) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);
+
+ /*
+ * Compile (if necessary) and disassemble a method body.
+ */
+
+ methodBody:
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"",
+ TclGetString(objv[3]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[3]), NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "body not available for this kind of method", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
+ return TCL_ERROR;
+ }
+ if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ Command cmd;
+
+ /*
+ * Yes, this is ugly, but we need to pass the namespace in to the
+ * compiler in two places.
+ */
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ procPtr->cmdPtr = &cmd;
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+ (Namespace *) oPtr->namespacePtr, "body of method",
+ TclGetString(objv[3]));
+ procPtr->cmdPtr = NULL;
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ codeObjPtr = procPtr->bodyPtr;
break;
+ default:
+ CLANG_ASSERT(0);
+ }
+
+ /*
+ * Do the actual disassembly.
+ */
+
+ if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
+ & TCL_BYTECODE_PRECOMPILED) {
+ Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "BYTECODE", NULL);
+ return TCL_ERROR;
}
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
return TCL_OK;
}
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index d340f4c..5c5af7b 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -53,8 +53,8 @@
*
* *** NOTE: this code has been altered slightly for use in Tcl: ***
* *** 1. Names have been changed, e.g. from re_comp to ***
- * *** TclRegComp, to avoid clashes with other ***
- * *** regexp implementations used by applications. ***
+ * *** TclRegComp, to avoid clashes with other ***
+ * *** regexp implementations used by applications. ***
*/
/*
@@ -100,7 +100,7 @@ static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* compiled form of the regular expression.
*/
-Tcl_ObjType tclRegexpType = {
+const Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
@@ -173,7 +173,7 @@ Tcl_RegExpExec(
* that "^" won't match. */
{
int flags, result, numChars;
- TclRegexp *regexp = (TclRegexp *)re;
+ TclRegexp *regexp = (TclRegexp *) re;
Tcl_DString ds;
const Tcl_UniChar *ustr;
@@ -391,9 +391,8 @@ Tcl_RegExpMatch(
const char *text, /* Text to search for pattern matches. */
const char *pattern) /* Regular expression to match against text. */
{
- Tcl_RegExp re;
+ Tcl_RegExp re = Tcl_RegExpCompile(interp, pattern);
- re = Tcl_RegExpCompile(interp, pattern);
if (re == NULL) {
return -1;
}
@@ -436,7 +435,8 @@ Tcl_RegExpExecObj(
Tcl_UniChar *udata;
int length;
int reflags = regexpPtr->flags;
-#define TCL_REG_GLOBOK_FLAGS (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
+#define TCL_REG_GLOBOK_FLAGS \
+ (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
/*
* Take advantage of the equivalent glob pattern, if one exists.
@@ -571,14 +571,14 @@ Tcl_GetRegExpFromObj(
{
int length;
TclRegexp *regexpPtr;
- char *pattern;
+ const char *pattern;
/*
* This is OK because we only actually interpret this value properly as a
* TclRegexp* when the type is tclRegexpType.
*/
- regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
+ regexpPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
@@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = (void *) regexpPtr;
+ objPtr->internalRep.otherValuePtr = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
@@ -654,7 +654,7 @@ TclRegAbout(
{0, NULL}
};
const struct infoname *inf;
- Tcl_Obj *infoObj;
+ Tcl_Obj *infoObj, *resultObj;
/*
* The reset here guarantees that the interpreter result is empty and
@@ -670,7 +670,8 @@ TclRegAbout(
* well and Tcl has other limits that constrain things as well...
*/
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ resultObj = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewIntObj((int) regexpPtr->re.re_nsub));
/*
@@ -684,7 +685,8 @@ TclRegAbout(
Tcl_NewStringObj(inf->text, -1));
}
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), infoObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
+ Tcl_SetObjResult(interp, resultObj);
return 0;
}
@@ -747,7 +749,7 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr;
/*
* If this is the last reference to the regexp, free it.
@@ -781,7 +783,7 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr;
regexpPtr->refCount++;
copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
@@ -903,7 +905,7 @@ CompileRegexp(
* This is a new expression, so compile it and add it to the cache.
*/
- regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
+ regexpPtr = ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
@@ -930,7 +932,7 @@ CompileRegexp(
* Clean up and report errors in the interpreter, if possible.
*/
- ckfree((char *)regexpPtr);
+ ckfree(regexpPtr);
if (interp) {
TclRegError(interp,
"couldn't compile regular expression pattern: ", status);
@@ -958,8 +960,8 @@ CompileRegexp(
* the entire pattern.
*/
- regexpPtr->matches = (regmatch_t *) ckalloc(
- sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
+ regexpPtr->matches =
+ ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
@@ -974,6 +976,7 @@ CompileRegexp(
if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
+
if (--(oldRegexpPtr->refCount) <= 0) {
FreeRegexp(oldRegexpPtr);
}
@@ -984,8 +987,8 @@ CompileRegexp(
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
- tsdPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
- strcpy(tsdPtr->patterns[0], string);
+ tsdPtr->patterns[0] = ckalloc(length + 1);
+ memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
@@ -1017,9 +1020,9 @@ FreeRegexp(
TclDecrRefCount(regexpPtr->globObjPtr);
}
if (regexpPtr->matches) {
- ckfree((char *) regexpPtr->matches);
+ ckfree(regexpPtr->matches);
}
- ckfree((char *) regexpPtr);
+ ckfree(regexpPtr);
}
/*
@@ -1054,10 +1057,12 @@ FinalizeRegexp(
ckfree(tsdPtr->patterns[i]);
tsdPtr->patterns[i] = NULL;
}
+
/*
* We may find ourselves reinitialized if another finalization routine
* invokes regexps.
*/
+
tsdPtr->initialized = 0;
}
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 8650776..3b2433e 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -28,7 +28,7 @@ typedef struct TclRegexp {
int flags; /* Regexp compile flags. */
regex_t re; /* Compiled re, includes number of
* subexpressions. */
- CONST char *string; /* Last string passed to Tcl_RegExpExec. */
+ const char *string; /* Last string passed to Tcl_RegExpExec. */
Tcl_Obj *objPtr; /* Last object passed to Tcl_RegExpExecObj. */
Tcl_Obj *globObjPtr; /* Glob pattern rep of RE or NULL if none. */
regmatch_t *matches; /* Array of indices into the Tcl_UniChar
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index 8bb5e2b..974737e 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -55,7 +55,7 @@ void
Tcl_AddInterpResolvers(
Tcl_Interp *interp, /* Interpreter whose name resolution rules are
* being modified. */
- CONST char *name, /* Name of this resolution scheme. */
+ const char *name, /* Name of this resolution scheme. */
Tcl_ResolveCmdProc *cmdProc,/* New function for command resolution. */
Tcl_ResolveVarProc *varProc,/* Function for variable resolution at
* runtime. */
@@ -65,6 +65,7 @@ Tcl_AddInterpResolvers(
{
Interp *iPtr = (Interp *) interp;
ResolverScheme *resPtr;
+ unsigned len;
/*
* Since we're adding a new name resolution scheme, we must force all code
@@ -100,9 +101,10 @@ Tcl_AddInterpResolvers(
* list, so that it overrides existing schemes.
*/
- resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
- resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1));
- strcpy(resPtr->name, name);
+ resPtr = ckalloc(sizeof(ResolverScheme));
+ len = strlen(name) + 1;
+ resPtr->name = ckalloc(len);
+ memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
@@ -134,7 +136,7 @@ int
Tcl_GetInterpResolvers(
Tcl_Interp *interp, /* Interpreter whose name resolution rules are
* being queried. */
- CONST char *name, /* Look for a scheme with this name. */
+ const char *name, /* Look for a scheme with this name. */
Tcl_ResolverInfo *resInfoPtr)
/* Returns pointers to the functions, if
* found */
@@ -186,7 +188,7 @@ int
Tcl_RemoveInterpResolvers(
Tcl_Interp *interp, /* Interpreter whose name resolution rules are
* being modified. */
- CONST char *name) /* Name of the scheme to be removed. */
+ const char *name) /* Name of the scheme to be removed. */
{
Interp *iPtr = (Interp *) interp;
ResolverScheme **prevPtrPtr, *resPtr;
@@ -224,7 +226,7 @@ Tcl_RemoveInterpResolvers(
*prevPtrPtr = resPtr->nextPtr;
ckfree(resPtr->name);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
return 1;
}
@@ -260,11 +262,23 @@ BumpCmdRefEpochs(
nsPtr->cmdRefEpoch++;
+#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
- Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
+ Namespace *childNsPtr = Tcl_GetHashValue(entry);
+
BumpCmdRefEpochs(childNsPtr);
}
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ for (entry = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ Namespace *childNsPtr = Tcl_GetHashValue(entry);
+
+ BumpCmdRefEpochs(childNsPtr);
+ }
+ }
+#endif
TclInvalidateNsPath(nsPtr);
}
@@ -280,8 +294,8 @@ BumpCmdRefEpochs(
*
* Command resolution is handled by a function of the following type:
*
- * typedef int (*Tcl_ResolveCmdProc)(Tcl_Interp *interp,
- * CONST char *name, Tcl_Namespace *context,
+ * typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp,
+ * const char *name, Tcl_Namespace *context,
* int flags, Tcl_Command *rPtr);
*
* Whenever a command is executed or Tcl_FindCommand is invoked within
@@ -295,8 +309,8 @@ BumpCmdRefEpochs(
* Variable resolution is handled by two functions. The first is called
* whenever a variable needs to be resolved at compile time:
*
- * typedef int (*Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
- * CONST char *name, Tcl_Namespace *context,
+ * typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
+ * const char *name, Tcl_Namespace *context,
* Tcl_ResolvedVarInfo *rPtr);
*
* If this function is able to resolve the name, it should return the
@@ -311,8 +325,8 @@ BumpCmdRefEpochs(
* the variable may be requested via Tcl_FindNamespaceVar.) This function
* has the following type:
*
- * typedef int (*Tcl_ResolveVarProc)(Tcl_Interp *interp,
- * CONST char *name, Tcl_Namespace *context,
+ * typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp,
+ * const char *name, Tcl_Namespace *context,
* int flags, Tcl_Var *rPtr);
*
* This function is quite similar to the compile-time version. It returns
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 7b58d44..60bae73 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -17,7 +17,7 @@
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
- KEY_LEVEL, KEY_OPTIONS, KEY_LAST
+ KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST
};
/*
@@ -44,6 +44,8 @@ typedef struct InterpState {
Tcl_Obj *errorCode;
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
+ Tcl_Obj *errorStack;
+ int resetErrorStack;
} InterpState;
/*
@@ -72,14 +74,16 @@ Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
- Interp *iPtr = (Interp *)interp;
- InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
+ Interp *iPtr = (Interp *) interp;
+ InterpState *statePtr = ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
statePtr->returnLevel = iPtr->returnLevel;
statePtr->returnCode = iPtr->returnCode;
statePtr->errorInfo = iPtr->errorInfo;
+ statePtr->errorStack = iPtr->errorStack;
+ statePtr->resetErrorStack = iPtr->resetErrorStack;
if (statePtr->errorInfo) {
Tcl_IncrRefCount(statePtr->errorInfo);
}
@@ -91,6 +95,9 @@ Tcl_SaveInterpState(
if (statePtr->returnOpts) {
Tcl_IncrRefCount(statePtr->returnOpts);
}
+ if (statePtr->errorStack) {
+ Tcl_IncrRefCount(statePtr->errorStack);
+ }
statePtr->objResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(statePtr->objResult);
return (Tcl_InterpState) statePtr;
@@ -119,8 +126,8 @@ Tcl_RestoreInterpState(
Tcl_Interp *interp, /* Interpreter's state to be restored. */
Tcl_InterpState state) /* Saved interpreter state. */
{
- Interp *iPtr = (Interp *)interp;
- InterpState *statePtr = (InterpState *)state;
+ Interp *iPtr = (Interp *) interp;
+ InterpState *statePtr = (InterpState *) state;
int status = statePtr->status;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
@@ -128,6 +135,7 @@ Tcl_RestoreInterpState(
iPtr->returnLevel = statePtr->returnLevel;
iPtr->returnCode = statePtr->returnCode;
+ iPtr->resetErrorStack = statePtr->resetErrorStack;
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
}
@@ -142,6 +150,13 @@ Tcl_RestoreInterpState(
if (iPtr->errorCode) {
Tcl_IncrRefCount(iPtr->errorCode);
}
+ if (iPtr->errorStack) {
+ Tcl_DecrRefCount(iPtr->errorStack);
+ }
+ iPtr->errorStack = statePtr->errorStack;
+ if (iPtr->errorStack) {
+ Tcl_IncrRefCount(iPtr->errorStack);
+ }
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
@@ -175,7 +190,7 @@ void
Tcl_DiscardInterpState(
Tcl_InterpState state) /* saved interpreter state */
{
- InterpState *statePtr = (InterpState *)state;
+ InterpState *statePtr = (InterpState *) state;
if (statePtr->errorInfo) {
Tcl_DecrRefCount(statePtr->errorInfo);
@@ -186,8 +201,11 @@ Tcl_DiscardInterpState(
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
+ if (statePtr->errorStack) {
+ Tcl_DecrRefCount(statePtr->errorStack);
+ }
Tcl_DecrRefCount(statePtr->objResult);
- ckfree((char *) statePtr);
+ ckfree(statePtr);
}
/*
@@ -313,7 +331,7 @@ Tcl_RestoreResult(
*/
if (iPtr->appendResult != NULL) {
- ckfree((char *) iPtr->appendResult);
+ ckfree(iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
@@ -366,7 +384,7 @@ Tcl_DiscardResult(
if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else {
- (*statePtr->freeProc)(statePtr->result);
+ statePtr->freeProc(statePtr->result);
}
}
}
@@ -399,7 +417,6 @@ Tcl_SetResult(
* a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
- int length;
register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
@@ -408,17 +425,18 @@ Tcl_SetResult(
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
- length = strlen(result);
+ int length = strlen(result);
+
if (length > TCL_RESULT_SIZE) {
- iPtr->result = (char *) ckalloc((unsigned) length+1);
+ iPtr->result = ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
- strcpy(iPtr->result, result);
+ memcpy(iPtr->result, result, (unsigned) length+1);
} else {
- iPtr->result = result;
+ iPtr->result = (char *) result;
iPtr->freeProc = freeProc;
}
@@ -432,7 +450,7 @@ Tcl_SetResult(
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
- (*oldFreeProc)(oldResult);
+ oldFreeProc(oldResult);
}
}
@@ -460,7 +478,7 @@ Tcl_SetResult(
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_GetStringResult(
register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
@@ -469,11 +487,13 @@ Tcl_GetStringResult(
* result, then reset the object result.
*/
- if (*(interp->result) == 0) {
+ Interp *iPtr = (Interp *) interp;
+
+ if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
- return interp->result;
+ return iPtr->result;
}
/*
@@ -523,7 +543,7 @@ Tcl_SetObjResult(
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -576,7 +596,7 @@ Tcl_GetObjResult(
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -628,14 +648,14 @@ Tcl_AppendResultVA(
* calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
*/
-#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
+#ifdef USE_INTERP_RESULT
/*
* Ensure that the interp->result is legal so old Tcl 7.* code still
* works. There's still embarrasingly much of it about...
*/
(void) Tcl_GetStringResult(interp);
-#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */
+#endif /* USE_INTERP_RESULT */
}
/*
@@ -697,7 +717,7 @@ void
Tcl_AppendElement(
Tcl_Interp *interp, /* Interpreter whose result is to be
* extended. */
- CONST char *element) /* String to convert to list element and add
+ const char *element) /* String to convert to list element and add
* to result. */
{
Interp *iPtr = (Interp *) interp;
@@ -811,7 +831,7 @@ SetupAppendBuffer(
} else {
totalSpace *= 2;
}
- new = (char *) ckalloc((unsigned) totalSpace);
+ new = ckalloc(totalSpace);
strcpy(new, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
@@ -858,7 +878,7 @@ Tcl_FreeResult(
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -896,7 +916,7 @@ Tcl_ResetResult(
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -920,6 +940,7 @@ Tcl_ResetResult(
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
+ iPtr->resetErrorStack = 1;
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
if (iPtr->returnOpts) {
@@ -962,13 +983,12 @@ ResetObjResult(
} else {
if (objResultPtr->bytes != tclEmptyStringRep) {
if (objResultPtr->bytes) {
- ckfree((char *) objResultPtr->bytes);
+ ckfree(objResultPtr->bytes);
}
objResultPtr->bytes = tclEmptyStringRep;
objResultPtr->length = 0;
}
TclFreeIntRep(objResultPtr);
- objResultPtr->typePtr = NULL;
}
}
@@ -1005,6 +1025,7 @@ Tcl_SetErrorCodeVA(
while (1) {
char *elem = va_arg(argList, char *);
+
if (elem == NULL) {
break;
}
@@ -1083,6 +1104,45 @@ Tcl_SetObjErrorCode(
/*
*----------------------------------------------------------------------
*
+ * Tcl_GetErrorLine --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetErrorLine(
+ Tcl_Interp *interp)
+{
+ return ((Interp *) interp)->errorLine;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorLine --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetErrorLine(
+ Tcl_Interp *interp,
+ int value)
+{
+ ((Interp *) interp)->errorLine = value;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* GetKeys --
*
* Returns a Tcl_Obj * array of the standard keys used in the return
@@ -1095,8 +1155,8 @@ Tcl_SetObjErrorCode(
* A Tcl_Obj * array.
*
* Side effects:
- * First time called in a thread, creates the keys (allocating memory)
- * and arranges for their cleanup at thread exit.
+ * First time called in a thread, creates the keys (allocating memory)
+ * and arranges for their cleanup at thread exit.
*
*----------------------------------------------------------------------
*/
@@ -1119,6 +1179,7 @@ GetKeys(void)
TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode");
TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo");
TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline");
+ TclNewLiteralStringObj(keys[KEY_ERRORSTACK],"-errorstack");
TclNewLiteralStringObj(keys[KEY_LEVEL], "-level");
TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options");
@@ -1130,7 +1191,7 @@ GetKeys(void)
* ... and arrange for their clenaup.
*/
- Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
+ Tcl_CreateThreadExitHandler(ReleaseKeys, keys);
}
return keys;
}
@@ -1147,7 +1208,7 @@ GetKeys(void)
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
@@ -1156,7 +1217,7 @@ static void
ReleaseKeys(
ClientData clientData)
{
- Tcl_Obj **keys = (Tcl_Obj **)clientData;
+ Tcl_Obj **keys = clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
@@ -1180,7 +1241,7 @@ ReleaseKeys(
* Returns the return code the [return] command should return.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1224,6 +1285,31 @@ TclProcessReturn(
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
+ if (valuePtr != NULL) {
+ int len, valueObjc;
+ Tcl_Obj **valueObjv;
+
+ if (Tcl_IsShared(iPtr->errorStack)) {
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
+ }
+ /*
+ * List extraction done after duplication to avoid moving the rug
+ * if someone does [return -errorstack [info errorstack]]
+ */
+ if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ iPtr->resetErrorStack = 0;
+ Tcl_ListObjLength(interp, iPtr->errorStack, &len);
+ /* reset while keeping the list intrep as much as possible */
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv);
+ }
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
@@ -1255,12 +1341,12 @@ TclProcessReturn(
* Parses, checks, and stores the options to the [return] command.
*
* Results:
- * Returns TCL_ERROR is any of the option values are invalid. Otherwise,
+ * Returns TCL_ERROR if any of the option values are invalid. Otherwise,
* returns TCL_OK, and writes the returnOpts, code, and level values to
* the pointers provided.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1269,16 +1355,16 @@ int
TclMergeReturnOptions(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[], /* Argument objects. */
+ Tcl_Obj *const objv[], /* Argument objects. */
Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj
* *) where the pointer to the merged return
- * options dictionary should be written */
+ * options dictionary should be written. */
int *codePtr, /* If not NULL, points to space where the
- * -code value should be written */
+ * -code value should be written. */
int *levelPtr) /* If not NULL, points to space where the
- * -level value should be written */
+ * -level value should be written. */
{
- int code=TCL_OK;
+ int code = TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
Tcl_Obj *returnOpts = Tcl_NewObj();
@@ -1286,12 +1372,12 @@ TclMergeReturnOptions(
for (; objc > 1; objv += 2, objc -= 2) {
int optLen;
- CONST char *opt = TclGetStringFromObj(objv[0], &optLen);
+ const char *opt = TclGetStringFromObj(objv[0], &optLen);
int compareLen;
- CONST char *compare =
+ const char *compare =
TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
- if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
+ if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
@@ -1308,6 +1394,8 @@ TclMergeReturnOptions(
Tcl_AppendResult(interp, "bad ", compare,
" value: expected dictionary but got \"",
TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
+ NULL);
goto error;
}
@@ -1333,27 +1421,10 @@ TclMergeReturnOptions(
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
- if ((valuePtr != NULL)
- && (TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &code))) {
- static CONST char *returnCodes[] = {
- "ok", "error", "return", "break", "continue", NULL
- };
-
- if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
- NULL, TCL_EXACT, &code)) {
- /*
- * Value is not a legal return code.
- */
-
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- TclGetString(valuePtr),
- "\": must be ok, error, return, break, "
- "continue, or an integer", NULL);
+ if (valuePtr != NULL) {
+ if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) {
goto error;
}
- }
- if (valuePtr != NULL) {
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
}
@@ -1373,6 +1444,7 @@ TclMergeReturnOptions(
Tcl_AppendResult(interp, "bad -level value: "
"expected non-negative integer but got \"",
TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
@@ -1394,11 +1466,47 @@ TclMergeReturnOptions(
Tcl_AppendResult(interp, "bad -errorcode value: "
"expected a list but got \"",
TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
+ NULL);
goto error;
}
}
/*
+ * Check for bogus -errorstack value.
+ */
+
+ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
+ if (valuePtr != NULL) {
+ int length;
+
+ if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
+ /*
+ * Value is not a list, which is illegal for -errorstack.
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad -errorstack value: "
+ "expected a list but got \"", TclGetString(valuePtr),
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
+ NULL);
+ goto error;
+ }
+ if (length % 2) {
+ /*
+ * Errorstack must always be an even-sized list
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp,
+ "forbidden odd-sized list for -errorstack: \"",
+ TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT",
+ "ODDSIZEDLIST_ERRORSTACK", NULL);
+ goto error;
+ }
+ }
+
+ /*
* Convert [return -code return -level X] to [return -code ok -level X+1]
*/
@@ -1475,6 +1583,7 @@ Tcl_GetReturnOptions(
if (result == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp, "", -1);
+ Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
}
if (iPtr->errorCode) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
@@ -1521,6 +1630,7 @@ Tcl_SetReturnOptions(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected dict but got \"",
TclGetString(options), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
@@ -1536,7 +1646,7 @@ Tcl_SetReturnOptions(
/*
*-------------------------------------------------------------------------
*
- * TclTransferResult --
+ * Tcl_TransferResult --
*
* Copy the result (and error information) from one interp to another.
* Used when one interp has caused another interp to evaluate a script
@@ -1562,7 +1672,7 @@ Tcl_SetReturnOptions(
*/
void
-TclTransferResult(
+Tcl_TransferResult(
Tcl_Interp *sourceInterp, /* Interp whose result and error information
* should be moved to the target interp.
* After moving result, this interp's result
@@ -1605,5 +1715,7 @@ TclTransferResult(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclScan.c b/generic/tclScan.c
index d83c8c9..d21bfaf 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -43,10 +43,10 @@ typedef struct CharSet {
* Declarations for functions used only in this file.
*/
-static char * BuildCharSet(CharSet *cset, char *format);
+static const char * BuildCharSet(CharSet *cset, const char *format);
static int CharInSet(CharSet *cset, int ch);
static void ReleaseCharSet(CharSet *cset);
-static int ValidateFormat(Tcl_Interp *interp, char *format,
+static int ValidateFormat(Tcl_Interp *interp, const char *format,
int numVars, int *totalVars);
/*
@@ -67,14 +67,14 @@ static int ValidateFormat(Tcl_Interp *interp, char *format,
*----------------------------------------------------------------------
*/
-static char *
+static const char *
BuildCharSet(
CharSet *cset,
- char *format) /* Points to first char of set. */
+ const char *format) /* Points to first char of set. */
{
Tcl_UniChar ch, start;
int offset, nranges;
- char *end;
+ const char *end;
memset(cset, 0, sizeof(CharSet));
@@ -101,10 +101,9 @@ BuildCharSet(
end += Tcl_UtfToUniChar(end, &ch);
}
- cset->chars = (Tcl_UniChar *)
- ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
+ cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
if (nranges > 0) {
- cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges);
+ cset->ranges = ckalloc(sizeof(struct Range) * nranges);
} else {
cset->ranges = NULL;
}
@@ -224,9 +223,9 @@ static void
ReleaseCharSet(
CharSet *cset)
{
- ckfree((char *)cset->chars);
+ ckfree(cset->chars);
if (cset->ranges) {
- ckfree((char *)cset->ranges);
+ ckfree(cset->ranges);
}
}
@@ -250,7 +249,7 @@ ReleaseCharSet(
static int
ValidateFormat(
Tcl_Interp *interp, /* Current interpreter. */
- char *format, /* The format string. */
+ const char *format, /* The format string. */
int numVars, /* The number of variables passed to the scan
* command. */
int *totalSubs) /* The number of variables that will be
@@ -260,7 +259,7 @@ ValidateFormat(
char *end;
Tcl_UniChar ch;
int objIndex, xpgSize, nspace = numVars;
- int *nassign = (int *) TclStackAlloc(interp, nspace * sizeof(int));
+ int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX+1];
/*
@@ -332,6 +331,7 @@ ValidateFormat(
Tcl_SetResult(interp,
"cannot mix \"%\" and \"%n$\" conversion specifiers",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
goto error;
}
@@ -341,7 +341,7 @@ ValidateFormat(
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
- value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
+ value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */
flags |= SCAN_WIDTH;
format += Tcl_UtfToUniChar(format, &ch);
}
@@ -378,6 +378,7 @@ ValidateFormat(
Tcl_SetResult(interp,
"field width may not be specified in %c conversion",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
/*
@@ -391,6 +392,7 @@ ValidateFormat(
Tcl_AppendResult(interp,
"field size modifier may not be specified in %", buf,
" conversion", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
goto error;
}
/*
@@ -403,11 +405,13 @@ ValidateFormat(
case 'i':
case 'o':
case 'x':
+ case 'b':
break;
case 'u':
if (flags & SCAN_BIG) {
Tcl_SetResult(interp,
"unsigned bignum scans are invalid", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
goto error;
}
break;
@@ -444,16 +448,14 @@ ValidateFormat(
badSet:
Tcl_SetResult(interp, "unmatched [ in format string",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
goto error;
default:
- {
- char buf[TCL_UTF_MAX+1];
-
- buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad scan conversion character \"",
- buf, "\"", NULL);
- goto error;
- }
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ Tcl_AppendResult(interp, "bad scan conversion character \"", buf,
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
+ goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
if (objIndex >= nspace) {
@@ -469,7 +471,7 @@ ValidateFormat(
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
- nassign = (int *) TclStackRealloc(interp, nassign,
+ nassign = TclStackRealloc(interp, nassign,
nspace * sizeof(int));
for (i = value; i < nspace; i++) {
nassign[i] = 0;
@@ -499,6 +501,7 @@ ValidateFormat(
Tcl_SetResult(interp,
"variable is assigned by multiple \"%n$\" conversion specifiers",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
/*
@@ -509,6 +512,7 @@ ValidateFormat(
Tcl_SetResult(interp,
"variable is not assigned by any conversion specifiers",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
goto error;
}
}
@@ -520,10 +524,12 @@ ValidateFormat(
if (gotXpg) {
Tcl_SetResult(interp, "\"%n$\" argument index out of range",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
} else {
Tcl_SetResult(interp,
"different numbers of variable names and field specifiers",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
}
error:
@@ -551,16 +557,16 @@ ValidateFormat(
/* ARGSUSED */
int
Tcl_ScanObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *format;
+ const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
- CONST char *string, *end, *baseString;
+ const char *string, *end, *baseString;
char op = 0;
int width, underflow = 0;
Tcl_WideInt wideValue;
@@ -573,7 +579,7 @@ Tcl_ScanObjCmd(
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
- "string format ?varName varName ...?");
+ "string format ?varName ...?");
return TCL_ERROR;
}
@@ -593,7 +599,7 @@ Tcl_ScanObjCmd(
*/
if (totalVars > 0) {
- objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars);
+ objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
@@ -673,7 +679,7 @@ Tcl_ScanObjCmd(
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
- width = (int) strtoul(format-1, &format, 10);/* INTL: "C" locale. */
+ width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */
format += Tcl_UtfToUniChar(format, &ch);
} else {
width = 0;
@@ -709,6 +715,7 @@ Tcl_ScanObjCmd(
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
+ CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
@@ -730,6 +737,10 @@ Tcl_ScanObjCmd(
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
+ case 'b':
+ op = 'i';
+ parseFlag |= TCL_PARSE_BINARY_ONLY;
+ break;
case 'u':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
@@ -812,6 +823,7 @@ Tcl_ScanObjCmd(
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
+ CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
string = end;
@@ -862,6 +874,7 @@ Tcl_ScanObjCmd(
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj((int)sch);
Tcl_IncrRefCount(objPtr);
+ CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
@@ -966,6 +979,7 @@ Tcl_ScanObjCmd(
}
}
Tcl_SetDoubleObj(objPtr, dvalue);
+ CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
string = end;
}
@@ -987,9 +1001,14 @@ Tcl_ScanObjCmd(
continue;
}
result++;
- if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
- Tcl_AppendResult(interp, "couldn't set variable \"",
- TclGetString(objv[i+3]), "\"", NULL);
+
+ /*
+ * In case of multiple errors in setting variables, just report
+ * the first one.
+ */
+
+ if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i],
+ (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) {
code = TCL_ERROR;
}
Tcl_DecrRefCount(objs[i]);
@@ -1015,7 +1034,7 @@ Tcl_ScanObjCmd(
}
}
if (objs != NULL) {
- ckfree((char*) objs);
+ ckfree(objs);
}
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index e8b7538..59192e9 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1,6 +1,4 @@
/*
- *----------------------------------------------------------------------
- *
* tclStrToD.c --
*
* This file contains a collection of procedures for managing conversions
@@ -13,7 +11,6 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *----------------------------------------------------------------------
*/
#include "tclInt.h"
@@ -38,6 +35,11 @@
#endif
/*
+ * Rounding controls. (Thanks a lot, Intel!)
+ */
+
+#ifdef __i386
+/*
* gcc on x86 needs access to rounding controls, because of a questionable
* feature where it retains intermediate results as IEEE 'long double' values
* somewhat unpredictably. It is tempting to include fpu_control.h, but that
@@ -45,41 +47,65 @@
* and ix86-isms are factored out here.
*/
-#if defined(__GNUC__) && defined(__i386)
-typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
-#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
-#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
+#if defined(__GNUC__)
+typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
+
+#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
+#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027f
# define ADJUST_FPU_CONTROL_WORD
-#endif
+#define TCL_IEEE_DOUBLE_ROUNDING \
+ fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
+ fpu_control_t oldRoundingMode; \
+ _FPU_GETCW(oldRoundingMode); \
+ _FPU_SETCW(roundTo53Bits)
+#define TCL_DEFAULT_DOUBLE_ROUNDING \
+ _FPU_SETCW(oldRoundingMode)
-/* Sun ProC needs sunmath for rounding control on x86 like gcc above.
- *
- *
+/*
+ * Sun ProC needs sunmath for rounding control on x86 like gcc above.
*/
-#if defined(__sun) && defined(__i386) && !defined(__GNUC__)
+#elif defined(__sun)
#include <sunmath.h>
+#define TCL_IEEE_DOUBLE_ROUNDING \
+ ieee_flags("set","precision","double",NULL)
+#define TCL_DEFAULT_DOUBLE_ROUNDING \
+ ieee_flags("clear","precision",NULL,NULL)
+
+/*
+ * Other platforms are assumed to always operate in full IEEE mode, so we make
+ * the macros to go in and out of that mode do nothing.
+ */
+
+#else /* !__GNUC__ && !__sun */
+#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
+#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
+#endif
+#else /* !__i386 */
+#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
+#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
#endif
/*
- * MIPS floating-point units need special settings in control registers
- * to use gradual underflow as we expect. This fix is for the MIPSpro
- * compiler.
+ * MIPS floating-point units need special settings in control registers to use
+ * gradual underflow as we expect. This fix is for the MIPSpro compiler.
*/
+
#if defined(__sgi) && defined(_COMPILER_VERSION)
#include <sys/fpu.h>
#endif
+
/*
* HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN.
* Everyone else uses 7ff8000000000000. (Why, HP, why?)
*/
#ifdef __hppa
-# define NAN_START 0x7ff4
-# define NAN_MASK (((Tcl_WideUInt) 1) << 50)
+# define NAN_START 0x7ff4
+# define NAN_MASK (((Tcl_WideUInt) 1) << 50)
#else
-# define NAN_START 0x7ff8
-# define NAN_MASK (((Tcl_WideUInt) 1) << 51)
+# define NAN_START 0x7ff8
+# define NAN_MASK (((Tcl_WideUInt) 1) << 51)
#endif
/*
@@ -93,45 +119,44 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define TWO_OVER_3LOG10 0.28952965460216784
#define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558
-/* Definitions of the parts of an IEEE754-format floating point number */
-
-#define SIGN_BIT 0x80000000
- /* Mask for the sign bit in the first
- * word of a double */
-#define EXP_MASK 0x7ff00000
- /* Mask for the exponent field in the
- * first word of a double */
-#define EXP_SHIFT 20
- /* Shift count to make the exponent an
- * integer */
-#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32)
- /* Hidden 1 bit for the significand */
-#define HI_ORDER_SIG_MASK 0x000fffff
+/*
+ * Definitions of the parts of an IEEE754-format floating point number.
+ */
+
+#define SIGN_BIT 0x80000000
+ /* Mask for the sign bit in the first word of
+ * a double. */
+#define EXP_MASK 0x7ff00000
+ /* Mask for the exponent field in the first
+ * word of a double. */
+#define EXP_SHIFT 20 /* Shift count to make the exponent an
+ * integer. */
+#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32)
+ /* Hidden 1 bit for the significand. */
+#define HI_ORDER_SIG_MASK 0x000fffff
/* Mask for the high-order part of the
* significand in the first word of a
- * double */
-#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \
- | 0xffffffff)
+ * double. */
+#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \
+ | 0xffffffff)
/* Mask for the 52-bit significand. */
-#define FP_PRECISION 53
- /* Number of bits of significand plus the
- * hidden bit */
-#define EXPONENT_BIAS 0x3ff
- /* Bias of the exponent 0 */
-
-/* Derived quantities */
-
-#define TEN_PMAX 22
- /* floor(FP_PRECISION*log(2)/log(5)) */
-#define QUICK_MAX 14
- /* floor((FP_PRECISION-1)*log(2)/log(10)) - 1 */
-#define BLETCH 0x10
- /* Highest power of two that is greater than
- * DBL_MAX_10_EXP, divided by 16 */
-#define DIGIT_GROUP 8
- /* floor(DIGIT_BIT*log(2)/log(10)) */
-
-/* Union used to dismantle floating point numbers. */
+#define FP_PRECISION 53 /* Number of bits of significand plus the
+ * hidden bit. */
+#define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */
+
+/*
+ * Derived quantities.
+ */
+
+#define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */
+#define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */
+#define BLETCH 0x10 /* Highest power of two that is greater than
+ * DBL_MAX_10_EXP, divided by 16. */
+#define DIGIT_GROUP 8 /* floor(DIGIT_BIT*log(2)/log(10)) */
+
+/*
+ * Union used to dismantle floating point numbers.
+ */
typedef union Double {
struct {
@@ -162,7 +187,7 @@ static int log2FLT_RADIX; /* Logarithm of the floating point radix. */
static int mantBits; /* Number of bits in a double's significand */
static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to
* 5**256 */
-static double tiny = 0.0; /* The smallest representable double */
+static double tiny = 0.0; /* The smallest representable double. */
static int maxDigits; /* The maximum number of digits to the left of
* the decimal point of a double. */
static int minDigits; /* The maximum number of digits to the right
@@ -186,10 +211,12 @@ static int n770_fp; /* Flag is 1 on Nokia N770 floating point.
* reversed: if big-endian is 7654 3210,
* and little-endian is 0123 4567,
* then Nokia's FP is 4567 0123;
- * little-endian within the 32-bit words
- * but big-endian between them. */
+ * little-endian within the 32-bit words but
+ * big-endian between them. */
-/* Table of powers of 5 that are small enough to fit in an mp_digit. */
+/*
+ * Table of powers of 5 that are small enough to fit in an mp_digit.
+ */
static const mp_digit dpow5[13] = {
1, 5, 25, 125,
@@ -198,7 +225,10 @@ static const mp_digit dpow5[13] = {
244140625
};
-/* Table of powers: pow5_13[n] = 5**(13*2**(n+1)) */
+/*
+ * Table of powers: pow5_13[n] = 5**(13*2**(n+1))
+ */
+
static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52,
* 5**104, 5**208 */
static const double tens[] = {
@@ -226,7 +256,6 @@ static const Tcl_WideUInt wtens[] = {
(Tcl_WideUInt) 1000000*100000, (Tcl_WideUInt) 1000000*1000000,
(Tcl_WideUInt) 1000000*1000000*10, (Tcl_WideUInt) 1000000*1000000*100,
(Tcl_WideUInt) 1000000*1000000*1000,(Tcl_WideUInt) 1000000*1000000*10000
-
};
static const double bigtens[] = {
@@ -275,75 +304,81 @@ static const Tcl_WideUInt wuipow5[27] = {
* Static functions defined in this file.
*/
-static int AccumulateDecimalDigit(unsigned, int,
+static int AccumulateDecimalDigit(unsigned, int,
Tcl_WideUInt *, mp_int *, int);
static double MakeHighPrecisionDouble(int signum,
mp_int *significand, int nSigDigs, int exponent);
static double MakeLowPrecisionDouble(int signum,
Tcl_WideUInt significand, int nSigDigs,
int exponent);
+#ifdef IEEE_FLOATING_POINT
static double MakeNaN(int signum, Tcl_WideUInt tag);
+#endif
static double RefineApproximation(double approx,
mp_int *exactSignificand, int exponent);
-static void MulPow5(mp_int*, unsigned, mp_int*);
-static int NormalizeRightward(Tcl_WideUInt*);
+static void MulPow5(mp_int *, unsigned, mp_int *);
+static int NormalizeRightward(Tcl_WideUInt *);
static int RequiredPrecision(Tcl_WideUInt);
-static void DoubleToExpAndSig(double, Tcl_WideUInt*, int*, int*);
-static void TakeAbsoluteValue(Double*, int*);
-static char* FormatInfAndNaN(Double*, int*, char**);
-static char* FormatZero(int*, char**);
+static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *,
+ int *);
+static void TakeAbsoluteValue(Double *, int *);
+static char * FormatInfAndNaN(Double *, int *, char **);
+static char * FormatZero(int *, char **);
static int ApproximateLog10(Tcl_WideUInt, int, int);
-static int BetterLog10(double, int, int*);
-static void ComputeScale(int, int, int*, int*, int*, int*);
-static void SetPrecisionLimits(int, int, int*, int*, int*, int*);
-static char* BumpUp(char*, char*, int*);
-static int AdjustRange(double*, int);
-static char* ShorteningQuickFormat(double, int, int, double,
- char*, int*);
-static char* StrictQuickFormat(double, int, int, double,
- char*, int*);
-static char* QuickConversion(double, int, int, int, int, int, int,
- int*, char**);
-static void CastOutPowersOf2(int*, int*, int*);
-static char* ShorteningInt64Conversion(Double*, int, Tcl_WideUInt,
+static int BetterLog10(double, int, int *);
+static void ComputeScale(int, int, int *, int *, int *, int *);
+static void SetPrecisionLimits(int, int, int *, int *, int *,
+ int *);
+static char * BumpUp(char *, char *, int *);
+static int AdjustRange(double *, int);
+static char * ShorteningQuickFormat(double, int, int, double,
+ char *, int *);
+static char * StrictQuickFormat(double, int, int, double,
+ char *, int *);
+static char * QuickConversion(double, int, int, int, int, int, int,
+ int *, char **);
+static void CastOutPowersOf2(int *, int *, int *);
+static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt,
int, int, int, int, int, int, int, int, int,
- int, int, int*, char**);
-static char* StrictInt64Conversion(Double*, int, Tcl_WideUInt,
+ int, int, int *, char **);
+static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt,
int, int, int, int, int, int,
- int, int, int*, char**);
-static int ShouldBankerRoundUpPowD(mp_int*, int, int);
-static int ShouldBankerRoundUpToNextPowD(mp_int*, mp_int*,
- int, int, int, mp_int*);
-static char* ShorteningBignumConversionPowD(Double* dPtr,
+ int, int, int *, char **);
+static int ShouldBankerRoundUpPowD(mp_int *, int, int);
+static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *,
+ int, int, int, mp_int *);
+static char * ShorteningBignumConversionPowD(Double *dPtr,
int convType, Tcl_WideUInt bw, int b2, int b5,
int m2plus, int m2minus, int m5,
- int sd, int k, int len,
- int ilim, int ilim1, int* decpt,
- char** endPtr);
-static char* StrictBignumConversionPowD(Double* dPtr, int convType,
+ int sd, int k, int len,
+ int ilim, int ilim1, int *decpt,
+ char **endPtr);
+static char * StrictBignumConversionPowD(Double *dPtr, int convType,
Tcl_WideUInt bw, int b2, int b5,
- int sd, int k, int len,
- int ilim, int ilim1, int* decpt,
- char** endPtr);
-static int ShouldBankerRoundUp(mp_int*, mp_int*, int);
-static int ShouldBankerRoundUpToNext(mp_int*, mp_int*, mp_int*,
- int, int, mp_int*);
-static char* ShorteningBignumConversion(Double* dPtr, int convType,
+ int sd, int k, int len,
+ int ilim, int ilim1, int *decpt,
+ char **endPtr);
+static int ShouldBankerRoundUp(mp_int *, mp_int *, int);
+static int ShouldBankerRoundUpToNext(mp_int *, mp_int *,
+ mp_int *, int, int, mp_int *);
+static char * ShorteningBignumConversion(Double *dPtr, int convType,
Tcl_WideUInt bw, int b2,
int m2plus, int m2minus,
- int s2, int s5, int k, int len,
- int ilim, int ilim1, int* decpt,
- char** endPtr);
-static char* StrictBignumConversion(Double* dPtr, int convType,
+ int s2, int s5, int k, int len,
+ int ilim, int ilim1, int *decpt,
+ char **endPtr);
+static char * StrictBignumConversion(Double *dPtr, int convType,
Tcl_WideUInt bw, int b2,
- int s2, int s5, int k, int len,
- int ilim, int ilim1, int* decpt,
- char** endPtr);
-static double BignumToBiasedFrExp(mp_int *big, int *machexp);
+ int s2, int s5, int k, int len,
+ int ilim, int ilim1, int *decpt,
+ char **endPtr);
+static double BignumToBiasedFrExp(const mp_int *big, int *machexp);
static double Pow10TimesFrExp(int exponent, double fraction,
int *machexp);
static double SafeLdExp(double fraction, int exponent);
+#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w);
+#endif
/*
*----------------------------------------------------------------------
@@ -372,14 +407,14 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w);
* - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are
* not part of the [scan] command's vocabulary. Use only in
* combination with TCL_PARSE_INTEGER_ONLY.
- * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether
+ * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether
* or not a prefix is present that would lead to octal parsing.
* Use only in combination with TCL_PARSE_INTEGER_ONLY.
- * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format,
+ * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format,
* whether or not a prefix is present that would lead to
* hexadecimal parsing. Use only in combination with
* TCL_PARSE_INTEGER_ONLY.
- * - TCL_PARSE_DECIMAL_ONLY: parse only in the decimal format, no
+ * - TCL_PARSE_DECIMAL_ONLY: parse only in the decimal format, no
* matter whether a 0 prefix would normally force a different
* base.
* - TCL_PARSE_NO_WHITESPACE: reject any leading/trailing whitespace
@@ -473,38 +508,38 @@ TclParseNumber(
} state = INITIAL;
enum State acceptState = INITIAL;
- int signum = 0; /* Sign of the number being parsed */
+ int signum = 0; /* Sign of the number being parsed. */
Tcl_WideUInt significandWide = 0;
/* Significand of the number being parsed (if
- * no overflow) */
+ * no overflow). */
mp_int significandBig; /* Significand of the number being parsed (if
- * it overflows significandWide) */
- int significandOverflow = 0;/* Flag==1 iff significandBig is used */
+ * it overflows significandWide). */
+ int significandOverflow = 0;/* Flag==1 iff significandBig is used. */
Tcl_WideUInt octalSignificandWide = 0;
/* Significand of an octal number; needed
* because we don't know whether a number with
* a leading zero is octal or decimal until
- * we've scanned forward to a '.' or 'e' */
+ * we've scanned forward to a '.' or 'e'. */
mp_int octalSignificandBig; /* Significand of octal number once
- * octalSignificandWide overflows */
+ * octalSignificandWide overflows. */
int octalSignificandOverflow = 0;
- /* Flag==1 if octalSignificandBig is used */
+ /* Flag==1 if octalSignificandBig is used. */
int numSigDigs = 0; /* Number of significant digits in the decimal
- * significand */
+ * significand. */
int numTrailZeros = 0; /* Number of trailing zeroes at the current
* point in the parse. */
int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal
- * point */
+ * point. */
int exponentSignum = 0; /* Signum of the exponent of a floating point
- * number */
- long exponent = 0; /* Exponent of a floating point number */
- const char *p; /* Pointer to next character to scan */
- size_t len; /* Number of characters remaining after p */
+ * number. */
+ long exponent = 0; /* Exponent of a floating point number. */
+ const char *p; /* Pointer to next character to scan. */
+ size_t len; /* Number of characters remaining after p. */
const char *acceptPoint; /* Pointer to position after last character in
- * an acceptable number */
+ * an acceptable number. */
size_t acceptLen; /* Number of characters following that
* point. */
- int status = TCL_OK; /* Status to return to caller */
+ int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
@@ -566,6 +601,8 @@ TclParseNumber(
break;
} else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
goto zerox;
+ } else if (flags & TCL_PARSE_BINARY_ONLY) {
+ goto zerob;
} else if (flags & TCL_PARSE_OCTAL_ONLY) {
goto zeroo;
} else if (isdigit(UCHAR(c))) {
@@ -592,9 +629,9 @@ TclParseNumber(
case ZERO:
/*
* Scanned a leading zero (perhaps with a + or -). Acceptable
- * inputs are digits, period, X, b, and E. If 8 or 9 is encountered,
- * the number can't be octal. This state and the OCTAL state
- * differ only in whether they recognize 'X' and 'b'.
+ * inputs are digits, period, X, b, and E. If 8 or 9 is
+ * encountered, the number can't be octal. This state and the
+ * OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
@@ -614,6 +651,9 @@ TclParseNumber(
state = ZERO_B;
break;
}
+ if (flags & TCL_PARSE_BINARY_ONLY) {
+ goto zerob;
+ }
if (c == 'o' || c == 'O') {
explicitOctal = 1;
state = ZERO_O;
@@ -799,6 +839,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
case ZERO_B:
+ zerob:
if (c == '0') {
numTrailZeros++;
state = BINARY;
@@ -1184,7 +1225,7 @@ TclParseNumber(
case OCTAL:
/*
- * Returning an octal integer. Final scaling step
+ * Returning an octal integer. Final scaling step.
*/
shift = 3 * numTrailZeros;
@@ -1245,7 +1286,7 @@ TclParseNumber(
case DECIMAL:
significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
&significandWide, &significandBig, significandOverflow);
- if (!significandOverflow && (significandWide > MOST_BITS+signum)) {
+ if (!significandOverflow && (significandWide > MOST_BITS+signum)){
significandOverflow = 1;
TclBNInitBignumFromWideUInt(&significandBig, significandWide);
}
@@ -1301,16 +1342,16 @@ TclParseNumber(
objPtr->typePtr = &tclDoubleType;
if (exponentSignum) {
- exponent = - exponent;
+ exponent = -exponent;
}
if (!significandOverflow) {
objPtr->internalRep.doubleValue = MakeLowPrecisionDouble(
signum, significandWide, numSigDigs,
- (numTrailZeros + exponent - numDigitsAfterDp));
+ numTrailZeros + exponent - numDigitsAfterDp);
} else {
objPtr->internalRep.doubleValue = MakeHighPrecisionDouble(
signum, &significandBig, numSigDigs,
- (numTrailZeros + exponent - numDigitsAfterDp));
+ numTrailZeros + exponent - numDigitsAfterDp);
}
break;
@@ -1327,12 +1368,12 @@ TclParseNumber(
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
- objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
+ objPtr->internalRep.doubleValue = MakeNaN(signum,significandWide);
objPtr->typePtr = &tclDoubleType;
break;
#endif
case INITIAL:
- /* This case only to silence compiler warning */
+ /* This case only to silence compiler warning. */
Tcl_Panic("TclParseNumber: state INITIAL can't happen here");
}
}
@@ -1404,7 +1445,7 @@ AccumulateDecimalDigit(
Tcl_WideUInt w;
/*
- * Try wide multiplication first
+ * Try wide multiplication first.
*/
if (!bignumFlag) {
@@ -1417,10 +1458,10 @@ AccumulateDecimalDigit(
*wideRepPtr = digit;
return 0;
} else if (numZeros >= maxpow10_wide
- || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) {
+ || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) {
/*
- * Wide multiplication will overflow. Expand the
- * number to a bignum and fall through into the bignum case.
+ * Wide multiplication will overflow. Expand the number to a
+ * bignum and fall through into the bignum case.
*/
TclBNInitBignumFromWideUInt(bignumRepPtr, w);
@@ -1428,6 +1469,7 @@ AccumulateDecimalDigit(
/*
* Wide multiplication.
*/
+
*wideRepPtr = w * pow10_wide[numZeros+1] + digit;
return 0;
}
@@ -1495,12 +1537,12 @@ AccumulateDecimalDigit(
static double
MakeLowPrecisionDouble(
int signum, /* 1 if the number is negative, 0 otherwise */
- Tcl_WideUInt significand, /* Significand of the number */
- int numSigDigs, /* Number of digits in the significand */
- int exponent) /* Power of ten */
+ Tcl_WideUInt significand, /* Significand of the number. */
+ int numSigDigs, /* Number of digits in the significand. */
+ int exponent) /* Power of ten. */
{
- double retval; /* Value of the number */
- mp_int significandBig; /* Significand expressed as a bignum */
+ double retval; /* Value of the number. */
+ mp_int significandBig; /* Significand expressed as a bignum. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
@@ -1510,15 +1552,7 @@ MakeLowPrecisionDouble(
* ulp, so we need to change rounding mode to 53-bits.
*/
-#if defined(__GNUC__) && defined(__i386)
- fpu_control_t roundTo53Bits = 0x027f;
- fpu_control_t oldRoundingMode;
- _FPU_GETCW(oldRoundingMode);
- _FPU_SETCW(roundTo53Bits);
-#endif
-#if defined(__sun) && defined(__i386) && !defined(__GNUC__)
- ieee_flags("set","precision","double",NULL);
-#endif
+ TCL_IEEE_DOUBLE_ROUNDING;
/*
* Test for the easy cases.
@@ -1533,10 +1567,12 @@ MakeLowPrecisionDouble(
* without special handling.
*/
- retval = (double)(Tcl_WideInt)significand * pow10vals[exponent];
+ retval = (double)
+ ((Tcl_WideInt)significand * pow10vals[exponent]);
goto returnValue;
} else {
int diff = DBL_DIG - numSigDigs;
+
if (exponent-diff <= mmaxpow) {
/*
* 10**exponent is not an exact integer, but
@@ -1545,8 +1581,8 @@ MakeLowPrecisionDouble(
* with only one roundoff.
*/
- volatile double factor =
- (double)(Tcl_WideInt)significand * pow10vals[diff];
+ volatile double factor = (double)
+ ((Tcl_WideInt)significand * pow10vals[diff]);
retval = factor * pow10vals[exponent-diff];
goto returnValue;
}
@@ -1559,7 +1595,8 @@ MakeLowPrecisionDouble(
* only one rounding.
*/
- retval = (double)(Tcl_WideInt)significand / pow10vals[-exponent];
+ retval = (double)
+ ((Tcl_WideInt)significand / pow10vals[-exponent]);
goto returnValue;
}
}
@@ -1588,12 +1625,7 @@ MakeLowPrecisionDouble(
* On gcc on x86, restore the floating point mode word.
*/
-#if defined(__GNUC__) && defined(__i386)
- _FPU_SETCW(oldRoundingMode);
-#endif
-#if defined(__sun) && defined(__i386) && !defined(__GNUC__)
- ieee_flags("clear","precision",NULL,NULL);
-#endif
+ TCL_DEFAULT_DOUBLE_ROUNDING;
return retval;
}
@@ -1618,13 +1650,13 @@ MakeLowPrecisionDouble(
static double
MakeHighPrecisionDouble(
- int signum, /* 1=negative, 0=nonnegative */
- mp_int *significand, /* Exact significand of the number */
- int numSigDigs, /* Number of significant digits */
- int exponent) /* Power of 10 by which to multiply */
+ int signum, /* 1=negative, 0=nonnegative. */
+ mp_int *significand, /* Exact significand of the number. */
+ int numSigDigs, /* Number of significant digits. */
+ int exponent) /* Power of 10 by which to multiply. */
{
double retval;
- int machexp; /* Machine exponent of a power of 10 */
+ int machexp; /* Machine exponent of a power of 10. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
@@ -1634,15 +1666,7 @@ MakeHighPrecisionDouble(
* ulp, so we need to change rounding mode to 53-bits.
*/
-#if defined(__GNUC__) && defined(__i386)
- fpu_control_t roundTo53Bits = 0x027f;
- fpu_control_t oldRoundingMode;
- _FPU_GETCW(oldRoundingMode);
- _FPU_SETCW(roundTo53Bits);
-#endif
-#if defined(__sun) && defined(__i386) && !defined(__GNUC__)
- ieee_flags("set","precision","double",NULL);
-#endif
+ TCL_IEEE_DOUBLE_ROUNDING;
/*
* Quick checks for over/underflow.
@@ -1673,9 +1697,9 @@ MakeHighPrecisionDouble(
goto returnValue;
}
retval = SafeLdExp(retval, machexp);
- if (tiny == 0.0) {
- tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits);
- }
+ if (tiny == 0.0) {
+ tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits);
+ }
if (retval < tiny) {
retval = tiny;
}
@@ -1701,12 +1725,8 @@ MakeHighPrecisionDouble(
* On gcc on x86, restore the floating point mode word.
*/
-#if defined(__GNUC__) && defined(__i386)
- _FPU_SETCW(oldRoundingMode);
-#endif
-#if defined(__sun) && defined(__i386) && !defined(__GNUC__)
- ieee_flags("clear","precision",NULL,NULL);
-#endif
+ TCL_DEFAULT_DOUBLE_ROUNDING;
+
return retval;
}
@@ -1725,8 +1745,8 @@ MakeHighPrecisionDouble(
#ifdef IEEE_FLOATING_POINT
static double
MakeNaN(
- int signum, /* Sign bit (1=negative, 0=nonnegative */
- Tcl_WideUInt tags) /* Tag bits to put in the NaN */
+ int signum, /* Sign bit (1=negative, 0=nonnegative. */
+ Tcl_WideUInt tags) /* Tag bits to put in the NaN. */
{
union {
Tcl_WideUInt iv;
@@ -1764,28 +1784,28 @@ MakeNaN(
static double
RefineApproximation(
- double approxResult, /* Approximate result of conversion */
- mp_int *exactSignificand, /* Integer significand */
- int exponent) /* Power of 10 to multiply by significand */
+ double approxResult, /* Approximate result of conversion. */
+ mp_int *exactSignificand, /* Integer significand. */
+ int exponent) /* Power of 10 to multiply by significand. */
{
int M2, M5; /* Powers of 2 and of 5 needed to put the
* decimal and binary numbers over a common
* denominator. */
- double significand; /* Sigificand of the binary number */
- int binExponent; /* Exponent of the binary number */
+ double significand; /* Sigificand of the binary number. */
+ int binExponent; /* Exponent of the binary number. */
int msb; /* Most significant bit position of an
- * intermediate result */
+ * intermediate result. */
int nDigits; /* Number of mp_digit's in an intermediate
- * result */
+ * result. */
mp_int twoMv; /* Approx binary value expressed as an exact
- * integer scaled by the multiplier 2M */
+ * integer scaled by the multiplier 2M. */
mp_int twoMd; /* Exact decimal value expressed as an exact
- * integer scaled by the multiplier 2M */
- int scale; /* Scale factor for M */
- int multiplier; /* Power of two to scale M */
+ * integer scaled by the multiplier 2M. */
+ int scale; /* Scale factor for M. */
+ int multiplier; /* Power of two to scale M. */
double num, den; /* Numerator and denominator of the correction
- * term */
- double quot; /* Correction term */
+ * term. */
+ double quot; /* Correction term. */
double minincr; /* Lower bound on the absolute value of the
* correction term. */
int i;
@@ -1815,8 +1835,8 @@ RefineApproximation(
M5 = 0;
} else {
M5 = -exponent;
- if ((M5-1) > M2) {
- M2 = M5-1;
+ if (M5 - 1 > M2) {
+ M2 = M5 - 1;
}
}
@@ -1855,7 +1875,7 @@ RefineApproximation(
mp_init_copy(&twoMd, exactSignificand);
for (i=0; i<=8; ++i) {
- if ((M5+exponent) & (1 << i)) {
+ if ((M5 + exponent) & (1 << i)) {
mp_mul(&twoMd, pow5+i, &twoMd);
}
}
@@ -1865,7 +1885,7 @@ RefineApproximation(
/*
* The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
* term. Because 2M may well overflow a double, we need to scale the
- * denominator by a factor of 2**binExponent-mantBits
+ * denominator by a factor of 2**binExponent-mantBits.
*/
scale = binExponent - mantBits - 1;
@@ -1889,8 +1909,8 @@ RefineApproximation(
*/
if (mp_cmp_mag(&twoMd, &twoMv) == MP_LT) {
- mp_clear(&twoMd);
- mp_clear(&twoMv);
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
return approxResult;
}
@@ -1918,26 +1938,28 @@ RefineApproximation(
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* MultPow5 --
*
* Multiply a bignum by a power of 5.
*
* Side effects:
- * Stores base*5**n in result
+ * Stores base*5**n in result.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-MulPow5(mp_int* base, /* Number to multiply */
- unsigned n, /* Power of 5 to multiply by */
- mp_int* result) /* Place to store the result */
+MulPow5(
+ mp_int *base, /* Number to multiply. */
+ unsigned n, /* Power of 5 to multiply by. */
+ mp_int *result) /* Place to store the result. */
{
- mp_int* p = base;
+ mp_int *p = base;
int n13 = n / 13;
int r = n % 13;
+
if (r != 0) {
mp_mul_d(p, dpow5[r], result);
p = result;
@@ -1955,14 +1977,14 @@ MulPow5(mp_int* base, /* Number to multiply */
mp_copy(p, result);
}
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* NormalizeRightward --
*
- * Shifts a number rightward until it is odd (that is, until the
- * least significant bit is nonzero.
+ * Shifts a number rightward until it is odd (that is, until the least
+ * significant bit is nonzero.
*
* Results:
* Returns the number of bit positions by which the number was shifted.
@@ -1970,18 +1992,19 @@ MulPow5(mp_int* base, /* Number to multiply */
* Side effects:
* Shifts the number in place; *wPtr is replaced by the shifted number.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-NormalizeRightward(Tcl_WideUInt* wPtr)
- /* INOUT: Number to shift */
+NormalizeRightward(
+ Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
+
if (!(w & (Tcl_WideUInt) 0xffffffff)) {
w >>= 32; rv += 32;
- }
+ }
if (!(w & (Tcl_WideUInt) 0xffff)) {
w >>= 16; rv += 16;
}
@@ -2000,27 +2023,28 @@ NormalizeRightward(Tcl_WideUInt* wPtr)
*wPtr = w;
return rv;
}
-
+
/*
- *-----------------------------------------------------------------------------0
+ *----------------------------------------------------------------------
*
* RequiredPrecision --
*
* Determines the number of bits needed to hold an intger.
*
* Results:
- * Returns the position of the most significant bit (0 - 63).
- * Returns 0 if the number is zero.
+ * Returns the position of the most significant bit (0 - 63). Returns 0
+ * if the number is zero.
*
- *----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static int
-RequiredPrecision(Tcl_WideUInt w)
- /* Number to interrogate */
+RequiredPrecision(
+ Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
+
if (w & ((Tcl_WideUInt) 0xffffffff << 32)) {
wi = (unsigned long) (w >> 32); rv = 32;
} else {
@@ -2046,38 +2070,40 @@ RequiredPrecision(Tcl_WideUInt w)
}
return rv;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DoubleToExpAndSig --
*
* Separates a 'double' into exponent and significand.
*
* Side effects:
- * Stores the significand in '*significand' and the exponent in
- * '*expon' so that dv == significand * 2.0**expon, and significand
- * is odd. Also stores the position of the leftmost 1-bit in 'significand'
- * in 'bits'.
+ * Stores the significand in '*significand' and the exponent in '*expon'
+ * so that dv == significand * 2.0**expon, and significand is odd. Also
+ * stores the position of the leftmost 1-bit in 'significand' in 'bits'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-DoubleToExpAndSig(double dv, /* Number to convert */
- Tcl_WideUInt* significand,
- /* OUTPUT: Significand of the number */
- int* expon, /* OUTPUT: Exponent to multiply the number by */
- int* bits) /* OUTPUT: Number of significant bits */
+DoubleToExpAndSig(
+ double dv, /* Number to convert. */
+ Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */
+ int *expon, /* OUTPUT: Exponent to multiply the number
+ * by. */
+ int *bits) /* OUTPUT: Number of significant bits. */
{
- Double d; /* Number being converted */
- Tcl_WideUInt z; /* Significand under construction */
- int de; /* Exponent of the number */
- int k; /* Bit count */
+ Double d; /* Number being converted. */
+ Tcl_WideUInt z; /* Significand under construction. */
+ int de; /* Exponent of the number. */
+ int k; /* Bit count. */
d.d = dv;
- /* Extract exponent and significand */
+ /*
+ * Extract exponent and significand.
+ */
de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT;
z = d.q & SIG_MASK;
@@ -2093,24 +2119,25 @@ DoubleToExpAndSig(double dv, /* Number to convert */
}
*significand = z;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* TakeAbsoluteValue --
*
* Takes the absolute value of a 'double' including 0, Inf and NaN
*
* Side effects:
- * The 'double' in *d is replaced with its absolute value. The
- * signum is stored in 'sign': 1 for negative, 0 for nonnegative.
+ * The 'double' in *d is replaced with its absolute value. The signum is
+ * stored in 'sign': 1 for negative, 0 for nonnegative.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */
- int* sign) /* Place to put the signum */
+TakeAbsoluteValue(
+ Double *d, /* Number to replace with absolute value. */
+ int *sign) /* Place to put the signum. */
{
if (d->w.word0 & SIGN_BIT) {
*sign = 1;
@@ -2119,32 +2146,33 @@ TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */
*sign = 0;
}
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* FormatInfAndNaN --
*
* Bailout for formatting infinities and Not-A-Number.
*
* Results:
- * Returns one of the strings 'Infinity' and 'NaN'.
+ * Returns one of the strings 'Infinity' and 'NaN'. The string returned
+ * must be freed by the caller using 'ckfree'.
*
* Side effects:
- * Stores 9999 in *decpt, and sets '*endPtr' to designate the
- * terminating NUL byte of the string if 'endPtr' is not NULL.
+ * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating
+ * NUL byte of the string if 'endPtr' is not NULL.
*
- * The string returned must be freed by the caller using 'ckfree'.
- *
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-FormatInfAndNaN(Double* d, /* Exceptional number to format */
- int* decpt, /* Decimal point to set to a bogus value */
- char** endPtr) /* Pointer to the end of the formatted data */
+inline static char *
+FormatInfAndNaN(
+ Double *d, /* Exceptional number to format. */
+ int *decpt, /* Decimal point to set to a bogus value. */
+ char **endPtr) /* Pointer to the end of the formatted data */
{
- char* retval;
+ char *retval;
+
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
retval = ckalloc(9);
@@ -2161,9 +2189,9 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */
}
return retval;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* FormatZero --
*
@@ -2176,14 +2204,16 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */
* Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating
* the string in '*endPtr' if 'endPtr' is not NULL.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-FormatZero(int* decpt, /* Location of the decimal point */
- char** endPtr) /* Pointer to the end of the formatted data */
+inline static char *
+FormatZero(
+ int *decpt, /* Location of the decimal point. */
+ char **endPtr) /* Pointer to the end of the formatted data */
{
- char* retval = ckalloc(2);
+ char *retval = ckalloc(2);
+
strcpy(retval, "0");
if (endPtr) {
*endPtr = retval+1;
@@ -2191,37 +2221,37 @@ FormatZero(int* decpt, /* Location of the decimal point */
*decpt = 0;
return retval;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ApproximateLog10 --
*
- * Computes a two-term Taylor series approximation to the common
- * log of a number, and computes the number's binary log.
+ * Computes a two-term Taylor series approximation to the common log of a
+ * number, and computes the number's binary log.
*
* Results:
- * Return an approximation to floor(log10(bw*2**be)) that is either
- * exact or 1 too high.
+ * Return an approximation to floor(log10(bw*2**be)) that is either exact
+ * or 1 too high.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-ApproximateLog10(Tcl_WideUInt bw,
- /* Integer significand of the number */
- int be, /* Power of two to scale bw */
- int bbits) /* Number of bits of precision in bw */
+ApproximateLog10(
+ Tcl_WideUInt bw, /* Integer significand of the number. */
+ int be, /* Power of two to scale bw. */
+ int bbits) /* Number of bits of precision in bw. */
{
- int i; /* Log base 2 of the number */
+ int i; /* Log base 2 of the number. */
int k; /* Floor(Log base 10 of the number) */
- double ds; /* Mantissa of the number */
+ double ds; /* Mantissa of the number. */
Double d2;
/*
* Compute i and d2 such that d = d2*2**i, and 1 < d2 < 2.
- * Compute an approximation to log10(d),
- * log10(d) ~ log10(2) * i + log10(1.5)
+ * Compute an approximation to log10(d),
+ * log10(d) ~ log10(2) * i + log10(1.5)
* + (significand-1.5)/(1.5 * log(10))
*/
@@ -2229,17 +2259,16 @@ ApproximateLog10(Tcl_WideUInt bw,
d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT;
i = be + bbits - 1;
ds = (d2.d - 1.5) * TWO_OVER_3LOG10
- + LOG10_3HALVES_PLUS_FUDGE
- + LOG10_2 * i;
+ + LOG10_3HALVES_PLUS_FUDGE + LOG10_2 * i;
k = (int) ds;
if (k > ds) {
--k;
}
return k;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* BetterLog10 --
*
@@ -2247,24 +2276,27 @@ ApproximateLog10(Tcl_WideUInt bw,
* 1 .. 10**(TEN_PMAX)-1
*
* Side effects:
- * Sets k_check to 0 if the new result is known to be exact, and to
- * 1 if it may still be one too high.
+ * Sets k_check to 0 if the new result is known to be exact, and to 1 if
+ * it may still be one too high.
*
* Results:
- * Returns the improved approximation to log10(d)
+ * Returns the improved approximation to log10(d).
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-BetterLog10(double d, /* Original number to format */
- int k, /* Characteristic(Log base 10) of the number */
- int* k_check) /* Flag == 1 if k is inexact */
+BetterLog10(
+ double d, /* Original number to format. */
+ int k, /* Characteristic(Log base 10) of the
+ * number. */
+ int *k_check) /* Flag == 1 if k is inexact. */
{
- /*
- * Performance hack. If k is in the range 0..TEN_PMAX, then we can
- * use a powers-of-ten table to check it.
+ /*
+ * Performance hack. If k is in the range 0..TEN_PMAX, then we can use a
+ * powers-of-ten table to check it.
*/
+
if (k >= 0 && k <= TEN_PMAX) {
if (d < tens[k]) {
k--;
@@ -2275,40 +2307,41 @@ BetterLog10(double d, /* Original number to format */
}
return k;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ComputeScale --
*
* Prepares to format a floating-point number as decimal.
*
* Parameters:
- * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i.
- * The significand of x requires bbits bits to represent.
+ * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. The
+ * significand of x requires bbits bits to represent.
*
* Results:
* Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5
- * exactly represents the value of the x/10**k. This value will lie
- * in the range [1 .. 10), and allows for computing successive digits
- * by multiplying sig%10 by 10.
+ * exactly represents the value of the x/10**k. This value will lie in
+ * the range [1 .. 10), and allows for computing successive digits by
+ * multiplying sig%10 by 10.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */
- int k, /* Characteristic of log10(number) */
- int* b2, /* OUTPUT: Power of 2 in the numerator */
- int* b5, /* OUTPUT: Power of 5 in the numerator */
- int* s2, /* OUTPUT: Power of 2 in the denominator */
- int* s5) /* OUTPUT: Power of 5 in the denominator */
+ComputeScale(
+ int be, /* Exponent part of number: d = bw * 2**be. */
+ int k, /* Characteristic of log10(number). */
+ int *b2, /* OUTPUT: Power of 2 in the numerator. */
+ int *b5, /* OUTPUT: Power of 5 in the numerator. */
+ int *s2, /* OUTPUT: Power of 2 in the denominator. */
+ int *s5) /* OUTPUT: Power of 5 in the denominator. */
{
-
- /*
- * Scale numerator and denominator powers of 2 so that the
- * input binary number is the ratio of integers
+ /*
+ * Scale numerator and denominator powers of 2 so that the input binary
+ * number is the ratio of integers.
*/
+
if (be <= 0) {
*b2 = 0;
*s2 = -be;
@@ -2317,10 +2350,11 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */
*s2 = 0;
}
- /*
- * Scale numerator and denominator so that the output decimal number
- * is the ratio of integers
+ /*
+ * Scale numerator and denominator so that the output decimal number is
+ * the ratio of integers.
*/
+
if (k >= 0) {
*b5 = 0;
*s5 = k;
@@ -2333,49 +2367,45 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* SetPrecisionLimits --
*
- * Determines how many digits of significance should be computed
- * (and, hence, how much memory need be allocated) for formatting a
- * floating point number.
+ * Determines how many digits of significance should be computed (and,
+ * hence, how much memory need be allocated) for formatting a floating
+ * point number.
*
* Given that 'k' is floor(log10(x)):
- * if 'shortest' format is used, there will be at most 18 digits in the result.
+ * if 'shortest' format is used, there will be at most 18 digits in the
+ * result.
* if 'F' format is used, there will be at most 'ndigits' + k + 1 digits
* if 'E' format is used, there will be exactly 'ndigits' digits.
*
* Side effects:
- * Adjusts '*ndigitsPtr' to have a valid value.
- * Stores the maximum memory allocation needed in *iPtr.
- * Sets '*iLimPtr' to the limiting number of digits to convert if k
- * has been guessed correctly, and '*iLim1Ptr' to the limiting number
- * of digits to convert if k has been guessed to be one too high.
+ * Adjusts '*ndigitsPtr' to have a valid value. Stores the maximum memory
+ * allocation needed in *iPtr. Sets '*iLimPtr' to the limiting number of
+ * digits to convert if k has been guessed correctly, and '*iLim1Ptr' to
+ * the limiting number of digits to convert if k has been guessed to be
+ * one too high.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-SetPrecisionLimits(int convType,
- /* Type of conversion:
- * TCL_DD_SHORTEST
- * TCL_DD_STEELE0
- * TCL_DD_E_FMT
- * TCL_DD_F_FMT */
- int k, /* Floor(log10(number to convert)) */
- int* ndigitsPtr,
- /* IN/OUT: Number of digits requested
- * (Will be adjusted if needed) */
- int* iPtr, /* OUT: Maximum number of digits
- * to return */
- int *iLimPtr,/* OUT: Number of digits of significance
- * if the bignum method is used.*/
- int *iLim1Ptr)
- /* OUT: Number of digits of significance
- * if the quick method is used. */
+SetPrecisionLimits(
+ int convType, /* Type of conversion: TCL_DD_SHORTEST,
+ * TCL_DD_STEELE0, TCL_DD_E_FMT,
+ * TCL_DD_F_FMT. */
+ int k, /* Floor(log10(number to convert)) */
+ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be
+ * adjusted if needed). */
+ int *iPtr, /* OUT: Maximum number of digits to return. */
+ int *iLimPtr, /* OUT: Number of digits of significance if
+ * the bignum method is used.*/
+ int *iLim1Ptr) /* OUT: Number of digits of significance if
+ * the quick method is used. */
{
- switch(convType) {
+ switch (convType) {
case TCL_DD_SHORTEST0:
case TCL_DD_STEELE0:
*iLimPtr = *iLim1Ptr = -1;
@@ -2403,31 +2433,31 @@ SetPrecisionLimits(int convType,
Tcl_Panic("impossible conversion type in TclDoubleDigits");
}
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* BumpUp --
*
- * Increases a string of digits ending in a series of nines to
- * designate the next higher number. xxxxb9999... -> xxxx(b+1)0000...
+ * Increases a string of digits ending in a series of nines to designate
+ * the next higher number. xxxxb9999... -> xxxx(b+1)0000...
*
* Results:
* Returns a pointer to the end of the adjusted string.
*
* Side effects:
- * In the case that the string consists solely of '999999', sets it
- * to "1" and moves the decimal point (*kPtr) one place to the right.
+ * In the case that the string consists solely of '999999', sets it to
+ * "1" and moves the decimal point (*kPtr) one place to the right.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-
-inline static char*
-BumpUp(char* s, /* Cursor pointing one past the end of the
- * string */
- char* retval, /* Start of the string of digits */
- int* kPtr) /* Position of the decimal point */
+inline static char *
+BumpUp(
+ char *s, /* Cursor pointing one past the end of the
+ * string. */
+ char *retval, /* Start of the string of digits. */
+ int *kPtr) /* Position of the decimal point. */
{
while (*--s == '9') {
if (s == retval) {
@@ -2442,27 +2472,28 @@ BumpUp(char* s, /* Cursor pointing one past the end of the
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* AdjustRange --
*
- * Rescales a 'double' in preparation for formatting it using the
- * 'quick' double-to-string method.
+ * Rescales a 'double' in preparation for formatting it using the 'quick'
+ * double-to-string method.
*
* Results:
- * Returns the precision that has been lost in the prescaling as
- * a count of units in the least significant place.
+ * Returns the precision that has been lost in the prescaling as a count
+ * of units in the least significant place.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-AdjustRange(double* dPtr, /* INOUT: Number to adjust */
- int k) /* IN: floor(log10(d)) */
+AdjustRange(
+ double *dPtr, /* INOUT: Number to adjust. */
+ int k) /* IN: floor(log10(d)) */
{
int ieps; /* Number of roundoff errors that have
- * accumulated */
- double d = *dPtr; /* Number to adjust */
+ * accumulated. */
+ double d = *dPtr; /* Number to adjust. */
double ds;
int i, j, j1;
@@ -2472,6 +2503,7 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */
/*
* The number must be reduced to bring it into range.
*/
+
ds = tens[k & 0xf];
j = k >> 4;
if (j & BLETCH) {
@@ -2490,8 +2522,9 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */
d /= ds;
} else if ((j1 = -k) != 0) {
/*
- * The number must be increased to bring it into range
+ * The number must be increased to bring it into range.
*/
+
d *= tens[j1 & 0xf];
i = 0;
for (j = j1>>4; j; j>>=1) {
@@ -2508,52 +2541,52 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShorteningQuickFormat --
*
- * Returns a 'quick' format of a double precision number to a string
- * of digits, preferring a shorter string of digits if the shorter
- * string is still within 1/2 ulp of the number.
+ * Returns a 'quick' format of a double precision number to a string of
+ * digits, preferring a shorter string of digits if the shorter string is
+ * still within 1/2 ulp of the number.
*
* Results:
- * Returns the string of digits. Returns NULL if the 'quick' method
- * fails and the bignum method must be used.
+ * Returns the string of digits. Returns NULL if the 'quick' method fails
+ * and the bignum method must be used.
*
* Side effects:
* Stores the position of the decimal point at '*kPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-ShorteningQuickFormat(double d, /* Number to convert */
- int k, /* floor(log10(d)) */
- int ilim, /* Number of significant digits to return */
- double eps,
- /* Estimated roundoff error */
- char* retval,
- /* Buffer to receive the digit string */
- int* kPtr)
- /* Pointer to stash the position of
- * the decimal point */
+inline static char *
+ShorteningQuickFormat(
+ double d, /* Number to convert. */
+ int k, /* floor(log10(d)) */
+ int ilim, /* Number of significant digits to return. */
+ double eps, /* Estimated roundoff error. */
+ char *retval, /* Buffer to receive the digit string. */
+ int *kPtr) /* Pointer to stash the position of the
+ * decimal point. */
{
- char* s = retval; /* Cursor in the return value */
- int digit; /* Current digit */
+ char *s = retval; /* Cursor in the return value. */
+ int digit; /* Current digit. */
int i;
eps = 0.5 / tens[ilim-1] - eps;
i = 0;
for (;;) {
- /* Convert a digit */
+ /*
+ * Convert a digit.
+ */
digit = (int) d;
d -= digit;
*s++ = '0' + digit;
/*
- * Truncate the conversion if the string of digits is within
- * 1/2 ulp of the actual value.
+ * Truncate the conversion if the string of digits is within 1/2 ulp
+ * of the actual value.
*/
if (d < eps) {
@@ -2567,7 +2600,7 @@ ShorteningQuickFormat(double d, /* Number to convert */
/*
* Bail out if the conversion fails to converge to a sufficiently
- * precise value
+ * precise value.
*/
if (++i >= ilim) {
@@ -2584,40 +2617,44 @@ ShorteningQuickFormat(double d, /* Number to convert */
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* StrictQuickFormat --
*
- * Convert a double precision number of a string of a precise number
- * of digits, using the 'quick' double precision method.
+ * Convert a double precision number of a string of a precise number of
+ * digits, using the 'quick' double precision method.
*
* Results:
- * Returns the digit string, or NULL if the bignum method must be
- * used to do the formatting.
+ * Returns the digit string, or NULL if the bignum method must be used to
+ * do the formatting.
*
* Side effects:
* Stores the position of the decimal point in '*kPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-StrictQuickFormat(double d, /* Number to convert */
- int k, /* floor(log10(d)) */
- int ilim, /* Number of significant digits to return */
- double eps, /* Estimated roundoff error */
- char* retval, /* Start of the digit string */
- int* kPtr) /* Pointer to stash the position of
- * the decimal point */
+inline static char *
+StrictQuickFormat(
+ double d, /* Number to convert. */
+ int k, /* floor(log10(d)) */
+ int ilim, /* Number of significant digits to return. */
+ double eps, /* Estimated roundoff error. */
+ char *retval, /* Start of the digit string. */
+ int *kPtr) /* Pointer to stash the position of the
+ * decimal point. */
{
- char* s = retval; /* Cursor in the return value */
- int digit; /* Current digit of the answer */
+ char *s = retval; /* Cursor in the return value. */
+ int digit; /* Current digit of the answer. */
int i;
eps *= tens[ilim-1];
i = 1;
for (;;) {
- /* Extract a digit */
+ /*
+ * Extract a digit.
+ */
+
digit = (int) d;
d -= digit;
if (d == 0.0) {
@@ -2625,10 +2662,11 @@ StrictQuickFormat(double d, /* Number to convert */
}
*s++ = '0' + digit;
- /*
- * When the given digit count is reached, handle trailing strings
- * of 0 and 9.
+ /*
+ * When the given digit count is reached, handle trailing strings of 0
+ * and 9.
*/
+
if (i == ilim) {
if (d > 0.5 + eps) {
*kPtr = k;
@@ -2645,14 +2683,17 @@ StrictQuickFormat(double d, /* Number to convert */
}
}
- /* Advance to the next digit */
+ /*
+ * Advance to the next digit.
+ */
+
++i;
d *= 10.0;
}
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* QuickConversion --
*
@@ -2661,44 +2702,48 @@ StrictQuickFormat(double d, /* Number to convert */
* therefore be used for the intermediate results.
*
* Results:
- * Returns the converted string, or NULL if the bignum method must
- * be used.
+ * Returns the converted string, or NULL if the bignum method must be
+ * used.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-QuickConversion(double e, /* Number to format */
- int k, /* floor(log10(d)), approximately */
- int k_check, /* 0 if k is exact, 1 if it may be too high */
- int flags, /* Flags passed to dtoa:
+inline static char *
+QuickConversion(
+ double e, /* Number to format. */
+ int k, /* floor(log10(d)), approximately. */
+ int k_check, /* 0 if k is exact, 1 if it may be too high */
+ int flags, /* Flags passed to dtoa:
* TCL_DD_SHORTEN_FLAG */
- int len, /* Length of the return value */
- int ilim, /* Number of digits to store */
- int ilim1, /* Number of digits to store if we
- * musguessed k */
- int* decpt, /* OUTPUT: Location of the decimal point */
- char** endPtr) /* OUTPUT: Pointer to the terminal null byte */
+ int len, /* Length of the return value. */
+ int ilim, /* Number of digits to store. */
+ int ilim1, /* Number of digits to store if we misguessed
+ * k. */
+ int *decpt, /* OUTPUT: Location of the decimal point. */
+ char **endPtr) /* OUTPUT: Pointer to the terminal null
+ * byte. */
{
int ieps; /* Number of 1-ulp roundoff errors that have
- * accumulated in the calculation*/
- Double eps; /* Estimated roundoff error */
- char* retval; /* Returned string */
- char* end; /* Pointer to the terminal null byte in the
- * returned string */
+ * accumulated in the calculation. */
+ Double eps; /* Estimated roundoff error. */
+ char *retval; /* Returned string. */
+ char *end; /* Pointer to the terminal null byte in the
+ * returned string. */
volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */
/*
- * Bring d into the range [1 .. 10)
+ * Bring d into the range [1 .. 10).
*/
+
ieps = AdjustRange(&e, k);
d = e;
/*
- * If the guessed value of k didn't get d into range, adjust it
- * by one. If that leaves us outside the range in which quick format
- * is accurate, bail out.
+ * If the guessed value of k didn't get d into range, adjust it by one. If
+ * that leaves us outside the range in which quick format is accurate,
+ * bail out.
*/
+
if (k_check && d < 1. && ilim > 0) {
if (ilim1 < 0) {
return NULL;
@@ -2710,15 +2755,16 @@ QuickConversion(double e, /* Number to format */
}
/*
- * Compute estimated roundoff error
+ * Compute estimated roundoff error.
*/
+
eps.d = ieps * d + 7.;
eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT;
/*
- * Handle the peculiar case where the result has no significant
- * digits.
+ * Handle the peculiar case where the result has no significant digits.
*/
+
retval = ckalloc(len + 1);
if (ilim == 0) {
d -= 5.;
@@ -2735,7 +2781,9 @@ QuickConversion(double e, /* Number to format */
}
}
- /* Format the digit string */
+ /*
+ * Format the digit string.
+ */
if (flags & TCL_DD_SHORTEN_FLAG) {
end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt);
@@ -2754,106 +2802,99 @@ QuickConversion(double e, /* Number to format */
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* CastOutPowersOf2 --
*
- * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers
- * of 2 from numerator and denominator in preparation for the 'bignum'
- * method of floating point conversion.
+ * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers of 2
+ * from numerator and denominator in preparation for the 'bignum' method
+ * of floating point conversion.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static void
-CastOutPowersOf2(int* b2, /* Power of 2 to multiply the significand */
- int* m2, /* Power of 2 to multiply 1/2 ulp */
- int* s2) /* Power of 2 to multiply the common
- * denominator */
+CastOutPowersOf2(
+ int *b2, /* Power of 2 to multiply the significand. */
+ int *m2, /* Power of 2 to multiply 1/2 ulp. */
+ int *s2) /* Power of 2 to multiply the common
+ * denominator. */
{
int i;
+
if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the
- * numerator */
- if (*m2 < *s2) { /* Find the lowest common denominatorr */
+ * numerator. */
+ if (*m2 < *s2) { /* Find the lowest common denominator. */
i = *m2;
} else {
i = *s2;
}
- *b2 -= i; /* Reduce to lowest terms */
+ *b2 -= i; /* Reduce to lowest terms. */
*m2 -= i;
*s2 -= i;
}
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShorteningInt64Conversion --
*
- * Converts a double-precision number to the shortest string of
- * digits that reconverts exactly to the given number, or to
- * 'ilim' digits if that will yield a shorter result. The numerator and
- * denominator in David Gay's conversion algorithm are known to fit
- * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's.
+ * Converts a double-precision number to the shortest string of digits
+ * that reconverts exactly to the given number, or to 'ilim' digits if
+ * that will yield a shorter result. The numerator and denominator in
+ * David Gay's conversion algorithm are known to fit in Tcl_WideUInt,
+ * giving considerably faster arithmetic than mp_int's.
*
* Results:
- * Returns the string of significant decimal digits, in newly
- * allocated memory
+ * Returns the string of significant decimal digits, in newly allocated
+ * memory
*
* Side effects:
- * Stores the location of the decimal point in '*decpt' and the
- * location of the terminal null byte in '*endPtr'.
+ * Stores the location of the decimal point in '*decpt' and the location
+ * of the terminal null byte in '*endPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-ShorteningInt64Conversion(Double* dPtr,
- /* Original number to convert */
- int convType,
- /* Type of conversion (shortest, Steele,
- E format, F format) */
- Tcl_WideUInt bw,
- /* Integer significand */
- int b2, int b5,
- /* Scale factor for the significand
- * in the numerator */
- int m2plus, int m2minus, int m5,
- /* Scale factors for 1/2 ulp in
- * the numerator (will be different if
- * bw == 1 */
- int s2, int s5,
- /* Scale factors for the denominator */
- int k,
- /* Number of output digits before the decimal
- * point */
- int len,
- /* Number of digits to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Position of the terminal '\0'
- * at the end of the returned string */
+inline static char *
+ShorteningInt64Conversion(
+ Double *dPtr, /* Original number to convert. */
+ int convType, /* Type of conversion (shortest, Steele,
+ * E format, F format). */
+ Tcl_WideUInt bw, /* Integer significand. */
+ int b2, int b5, /* Scale factor for the significand in the
+ * numerator. */
+ int m2plus, int m2minus, int m5,
+ /* Scale factors for 1/2 ulp in the numerator
+ * (will be different if bw == 1. */
+ int s2, int s5, /* Scale factors for the denominator. */
+ int k, /* Number of output digits before the decimal
+ * point. */
+ int len, /* Number of digits to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Position of the terminal '\0' at
+ * the end of the returned string. */
{
-
- char* retval = ckalloc(len + 1);
- /* Output buffer */
+ char *retval = ckalloc(len + 1);
+ /* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
- /* Numerator of the fraction being converted */
+ /* Numerator of the fraction being
+ * converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
- /* Denominator of the fraction being
- * converted */
- Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result
- * is within roundoff of being exact */
- int digit; /* Current output digit */
- char* s = retval; /* Cursor in the output buffer */
- int i; /* Current position in the output buffer */
+ /* Denominator of the fraction being
+ * converted. */
+ Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result is
+ * within roundoff of being exact. */
+ int digit; /* Current output digit. */
+ char *s = retval; /* Cursor in the output buffer. */
+ int i; /* Current position in the output buffer. */
- /* Adjust if the logarithm was guessed wrong */
+ /*
+ * Adjust if the logarithm was guessed wrong.
+ */
if (b < S) {
b = 10 * b;
@@ -2862,12 +2903,16 @@ ShorteningInt64Conversion(Double* dPtr,
--k;
}
- /* Compute roundoff ranges */
+ /*
+ * Compute roundoff ranges.
+ */
mplus = wuipow5[m5] << m2plus;
mminus = wuipow5[m5] << m2minus;
- /* Loop through the digits */
+ /*
+ * Loop through the digits.
+ */
i = 1;
for (;;) {
@@ -2877,21 +2922,19 @@ ShorteningInt64Conversion(Double* dPtr,
}
b = b % S;
- /*
+ /*
* Does the current digit put us on the low side of the exact value
* but within within roundoff of being exact?
*/
- if (b < mplus
- || (b == mplus
- && convType != TCL_DD_STEELE0
- && (dPtr->w.word1 & 1) == 0)) {
+
+ if (b < mplus || (b == mplus
+ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
/*
- * Make sure we shouldn't be rounding *up* instead,
- * in case the next number above is closer
+ * Make sure we shouldn't be rounding *up* instead, in case the
+ * next number above is closer.
*/
- if (2 * b > S
- || (2 * b == S
- && (digit & 1) != 0)) {
+
+ if (2 * b > S || (2 * b == S && (digit & 1) != 0)) {
++digit;
if (digit == 10) {
*s++ = '9';
@@ -2900,7 +2943,9 @@ ShorteningInt64Conversion(Double* dPtr,
}
}
- /* Stash the current digit */
+ /*
+ * Stash the current digit.
+ */
*s++ = '0' + digit;
break;
@@ -2910,10 +2955,9 @@ ShorteningInt64Conversion(Double* dPtr,
* Does one plus the current digit put us within roundoff of the
* number?
*/
- if (b > S - mminus
- || (b == S - mminus
- && convType != TCL_DD_STEELE0
- && (dPtr->w.word1 & 1) == 0)) {
+
+ if (b > S - mminus || (b == S - mminus
+ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
@@ -2927,27 +2971,30 @@ ShorteningInt64Conversion(Double* dPtr,
/*
* Have we converted all the requested digits?
*/
+
*s++ = '0' + digit;
if (i == ilim) {
- if (2*b > S
- || (2*b == S && (digit & 1) != 0)) {
+ if (2*b > S || (2*b == S && (digit & 1) != 0)) {
s = BumpUp(s, retval, &k);
}
break;
}
-
- /* Advance to the next digit */
-
+
+ /*
+ * Advance to the next digit.
+ */
+
b = 10 * b;
mplus = 10 * mplus;
mminus = 10 * mminus;
++i;
}
- /*
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -2957,69 +3004,61 @@ ShorteningInt64Conversion(Double* dPtr,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* StrictInt64Conversion --
*
- * Converts a double-precision number to a fixed-length string of
- * 'ilim' digits that reconverts exactly to the given number.
- * ('ilim' should be replaced with 'ilim1' in the case where
- * log10(d) has been overestimated). The numerator and
- * denominator in David Gay's conversion algorithm are known to fit
- * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's.
+ * Converts a double-precision number to a fixed-length string of 'ilim'
+ * digits that reconverts exactly to the given number. ('ilim' should be
+ * replaced with 'ilim1' in the case where log10(d) has been
+ * overestimated). The numerator and denominator in David Gay's
+ * conversion algorithm are known to fit in Tcl_WideUInt, giving
+ * considerably faster arithmetic than mp_int's.
*
* Results:
- * Returns the string of significant decimal digits, in newly
- * allocated memory
+ * Returns the string of significant decimal digits, in newly allocated
+ * memory
*
* Side effects:
- * Stores the location of the decimal point in '*decpt' and the
- * location of the terminal null byte in '*endPtr'.
+ * Stores the location of the decimal point in '*decpt' and the location
+ * of the terminal null byte in '*endPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-StrictInt64Conversion(Double* dPtr,
- /* Original number to convert */
- int convType,
- /* Type of conversion (shortest, Steele,
- E format, F format) */
- Tcl_WideUInt bw,
- /* Integer significand */
- int b2, int b5,
- /* Scale factor for the significand
- * in the numerator */
- int s2, int s5,
- /* Scale factors for the denominator */
- int k,
- /* Number of output digits before the decimal
- * point */
- int len,
- /* Number of digits to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Position of the terminal '\0'
- * at the end of the returned string */
+inline static char *
+StrictInt64Conversion(
+ Double *dPtr, /* Original number to convert. */
+ int convType, /* Type of conversion (shortest, Steele,
+ * E format, F format). */
+ Tcl_WideUInt bw, /* Integer significand. */
+ int b2, int b5, /* Scale factor for the significand in the
+ * numerator. */
+ int s2, int s5, /* Scale factors for the denominator. */
+ int k, /* Number of output digits before the decimal
+ * point. */
+ int len, /* Number of digits to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Position of the terminal '\0' at
+ * the end of the returned string. */
{
-
- char* retval = ckalloc(len + 1);
- /* Output buffer */
+ char *retval = ckalloc(len + 1);
+ /* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
- /* Numerator of the fraction being converted */
+ /* Numerator of the fraction being
+ * converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
- /* Denominator of the fraction being
- * converted */
- int digit; /* Current output digit */
- char* s = retval; /* Cursor in the output buffer */
- int i; /* Current position in the output buffer */
+ /* Denominator of the fraction being
+ * converted. */
+ int digit; /* Current output digit. */
+ char *s = retval; /* Cursor in the output buffer. */
+ int i; /* Current position in the output buffer. */
- /* Adjust if the logarithm was guessed wrong */
+ /*
+ * Adjust if the logarithm was guessed wrong.
+ */
if (b < S) {
b = 10 * b;
@@ -3027,7 +3066,9 @@ StrictInt64Conversion(Double* dPtr,
--k;
}
- /* Loop through the digits */
+ /*
+ * Loop through the digits.
+ */
i = 1;
for (;;) {
@@ -3040,10 +3081,10 @@ StrictInt64Conversion(Double* dPtr,
/*
* Have we converted all the requested digits?
*/
+
*s++ = '0' + digit;
if (i == ilim) {
- if (2*b > S
- || (2*b == S && (digit & 1) != 0)) {
+ if (2*b > S || (2*b == S && (digit & 1) != 0)) {
s = BumpUp(s, retval, &k);
} else {
while (*--s == '0') {
@@ -3053,17 +3094,20 @@ StrictInt64Conversion(Double* dPtr,
}
break;
}
-
- /* Advance to the next digit */
-
+
+ /*
+ * Advance to the next digit.
+ */
+
b = 10 * b;
++i;
}
- /*
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -3073,30 +3117,30 @@ StrictInt64Conversion(Double* dPtr,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShouldBankerRoundUpPowD --
*
- * Test whether bankers' rounding should round a digit up. Assumption
- * is made that the denominator of the fraction being tested is
- * a power of 2**DIGIT_BIT.
+ * Test whether bankers' rounding should round a digit up. Assumption is
+ * made that the denominator of the fraction being tested is a power of
+ * 2**DIGIT_BIT.
*
* Results:
- * Returns 1 iff the fraction is more than 1/2, or if the fraction
- * is exactly 1/2 and the digit is odd.
+ * Returns 1 iff the fraction is more than 1/2, or if the fraction is
+ * exactly 1/2 and the digit is odd.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-ShouldBankerRoundUpPowD(mp_int* b,
- /* Numerator of the fraction */
- int sd, /* Denominator is 2**(sd*DIGIT_BIT) */
- int isodd)
- /* 1 if the digit is odd, 0 if even */
+ShouldBankerRoundUpPowD(
+ mp_int *b, /* Numerator of the fraction. */
+ int sd, /* Denominator is 2**(sd*DIGIT_BIT). */
+ int isodd) /* 1 if the digit is odd, 0 if even. */
{
int i;
- const static mp_digit topbit = (1<<(DIGIT_BIT-1));
+ static const mp_digit topbit = 1 << (DIGIT_BIT - 1);
+
if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
return 0;
}
@@ -3112,45 +3156,41 @@ ShouldBankerRoundUpPowD(mp_int* b,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShouldBankerRoundUpToNextPowD --
*
- * Tests whether bankers' rounding will round down in the
- * "denominator is a power of 2**MP_DIGIT" case.
+ * Tests whether bankers' rounding will round down in the "denominator is
+ * a power of 2**MP_DIGIT" case.
*
* Results:
* Returns 1 if the rounding will be performed - which increases the
* digit by one - and 0 otherwise.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-ShouldBankerRoundUpToNextPowD(mp_int* b,
- /* Numerator of the fraction */
- mp_int* m,
- /* Numerator of the rounding tolerance */
- int sd,
- /* Common denominator is 2**(sd*DIGIT_BIT) */
- int convType,
- /* Conversion type: STEELE defeats
- * round-to-even (Not sure why one wants to
- * do this; I copied it from Gay) FIXME */
- int isodd,
- /* 1 if the integer significand is odd */
- mp_int* temp)
- /* Work area for the calculation */
+ShouldBankerRoundUpToNextPowD(
+ mp_int *b, /* Numerator of the fraction. */
+ mp_int *m, /* Numerator of the rounding tolerance. */
+ int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */
+ int convType, /* Conversion type: STEELE defeats
+ * round-to-even (not sure why one wants to do
+ * this; I copied it from Gay). FIXME */
+ int isodd, /* 1 if the integer significand is odd. */
+ mp_int *temp) /* Work area for the calculation. */
{
int i;
- /*
- * Compare B and S-m -- which is the same as comparing B+m and S --
- * which we do by computing b+m and doing a bitwhack compare against
+ /*
+ * Compare B and S-m - which is the same as comparing B+m and S - which we
+ * do by computing b+m and doing a bitwhack compare against
* 2**(DIGIT_BIT*sd)
*/
+
mp_add(b, m, temp);
- if (temp->used <= sd) { /* too few digits to be > S */
+ if (temp->used <= sd) { /* Too few digits to be > s */
return 0;
}
if (temp->used > sd+1 || temp->dp[sd] > 1) {
@@ -3158,85 +3198,74 @@ ShouldBankerRoundUpToNextPowD(mp_int* b,
return 1;
}
for (i = sd-1; i >= 0; --i) {
- /* check for ==s */
+ /* Check for ==s */
if (temp->dp[i] != 0) { /* > s */
return 1;
}
}
if (convType == TCL_DD_STEELE0) {
- /* biased rounding */
+ /* Biased rounding. */
return 0;
}
return isodd;
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShorteningBignumConversionPowD --
*
- * Converts a double-precision number to the shortest string of
- * digits that reconverts exactly to the given number, or to
- * 'ilim' digits if that will yield a shorter result. The denominator
- * in David Gay's conversion algorithm is known to be a power of
- * 2**DIGIT_BIT, and hence the division in the main loop may be replaced
- * by a digit shift and mask.
+ * Converts a double-precision number to the shortest string of digits
+ * that reconverts exactly to the given number, or to 'ilim' digits if
+ * that will yield a shorter result. The denominator in David Gay's
+ * conversion algorithm is known to be a power of 2**DIGIT_BIT, and hence
+ * the division in the main loop may be replaced by a digit shift and
+ * mask.
*
* Results:
- * Returns the string of significant decimal digits, in newly
- * allocated memory
+ * Returns the string of significant decimal digits, in newly allocated
+ * memory
*
* Side effects:
- * Stores the location of the decimal point in '*decpt' and the
- * location of the terminal null byte in '*endPtr'.
+ * Stores the location of the decimal point in '*decpt' and the location
+ * of the terminal null byte in '*endPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-ShorteningBignumConversionPowD(Double* dPtr,
- /* Original number to convert */
- int convType,
- /* Type of conversion (shortest, Steele,
- E format, F format) */
- Tcl_WideUInt bw,
- /* Integer significand */
- int b2, int b5,
- /* Scale factor for the significand
- * in the numerator */
- int m2plus, int m2minus, int m5,
- /* Scale factors for 1/2 ulp in
- * the numerator (will be different if
- * bw == 1 */
- int sd,
- /* Scale factor for the denominator */
- int k,
- /* Number of output digits before the decimal
- * point */
- int len,
- /* Number of digits to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Position of the terminal '\0'
- * at the end of the returned string */
+inline static char *
+ShorteningBignumConversionPowD(
+ Double *dPtr, /* Original number to convert. */
+ int convType, /* Type of conversion (shortest, Steele,
+ * E format, F format). */
+ Tcl_WideUInt bw, /* Integer significand. */
+ int b2, int b5, /* Scale factor for the significand in the
+ * numerator. */
+ int m2plus, int m2minus, int m5,
+ /* Scale factors for 1/2 ulp in the numerator
+ * (will be different if bw == 1). */
+ int sd, /* Scale factor for the denominator. */
+ int k, /* Number of output digits before the decimal
+ * point. */
+ int len, /* Number of digits to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Position of the terminal '\0' at
+ * the end of the returned string. */
{
-
- char* retval = ckalloc(len + 1);
- /* Output buffer */
- mp_int b; /* Numerator of the fraction being converted */
- mp_int mplus, mminus; /* Bounds for roundoff */
- mp_digit digit; /* Current output digit */
- char* s = retval; /* Cursor in the output buffer */
- int i; /* Index in the output buffer */
+ char *retval = ckalloc(len + 1);
+ /* Output buffer. */
+ mp_int b; /* Numerator of the fraction being
+ * converted. */
+ mp_int mplus, mminus; /* Bounds for roundoff. */
+ mp_digit digit; /* Current output digit. */
+ char *s = retval; /* Cursor in the output buffer. */
+ int i; /* Index in the output buffer. */
mp_int temp;
int r1;
- /*
+ /*
* b = bw * 2**b2 * 5**b5
* mminus = 5**m5
*/
@@ -3246,7 +3275,9 @@ ShorteningBignumConversionPowD(Double* dPtr,
MulPow5(&b, b5, &b);
mp_mul_2d(&b, b2, &b);
- /* Adjust if the logarithm was guessed wrong */
+ /*
+ * Adjust if the logarithm was guessed wrong.
+ */
if (b.used <= sd) {
mp_mul_d(&b, 10, &b);
@@ -3268,8 +3299,10 @@ ShorteningBignumConversionPowD(Double* dPtr,
}
mp_init(&temp);
- /* Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT)
- * by mp_digit extraction */
+ /*
+ * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT)
+ * by mp_digit extraction.
+ */
i = 0;
for (;;) {
@@ -3283,20 +3316,19 @@ ShorteningBignumConversionPowD(Double* dPtr,
--b.used; mp_clamp(&b);
}
- /*
+ /*
* Does the current digit put us on the low side of the exact value
* but within within roundoff of being exact?
*/
-
+
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
- if (r1 == MP_LT
- || (r1 == MP_EQ
- && convType != TCL_DD_STEELE0
- && (dPtr->w.word1 & 1) == 0)) {
+ if (r1 == MP_LT || (r1 == MP_EQ
+ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
/*
- * Make sure we shouldn't be rounding *up* instead,
- * in case the next number above is closer
+ * Make sure we shouldn't be rounding *up* instead, in case the
+ * next number above is closer.
*/
+
if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) {
++digit;
if (digit == 10) {
@@ -3306,7 +3338,9 @@ ShorteningBignumConversionPowD(Double* dPtr,
}
}
- /* Stash the last digit */
+ /*
+ * Stash the last digit.
+ */
*s++ = '0' + digit;
break;
@@ -3316,10 +3350,9 @@ ShorteningBignumConversionPowD(Double* dPtr,
* Does one plus the current digit put us within roundoff of the
* number?
*/
-
- if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd,
- convType, dPtr->w.word1 & 1,
- &temp)) {
+
+ if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType,
+ dPtr->w.word1 & 1, &temp)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
@@ -3333,6 +3366,7 @@ ShorteningBignumConversionPowD(Double* dPtr,
/*
* Have we converted all the requested digits?
*/
+
*s++ = '0' + digit;
if (i == ilim) {
if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) {
@@ -3340,9 +3374,11 @@ ShorteningBignumConversionPowD(Double* dPtr,
}
break;
}
-
- /* Advance to the next digit */
-
+
+ /*
+ * Advance to the next digit.
+ */
+
mp_mul_d(&b, 10, &b);
mp_mul_d(&mminus, 10, &mminus);
if (m2plus > m2minus) {
@@ -3351,10 +3387,11 @@ ShorteningBignumConversionPowD(Double* dPtr,
++i;
}
- /*
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
if (m2plus > m2minus) {
mp_clear(&mplus);
}
@@ -3368,65 +3405,55 @@ ShorteningBignumConversionPowD(Double* dPtr,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* StrictBignumConversionPowD --
*
- * Converts a double-precision number to a fixed-lengt string of
- * 'ilim' digits (or 'ilim1' if log10(d) has been overestimated.)
- * The denominator in David Gay's conversion algorithm is known to
- * be a power of 2**DIGIT_BIT, and hence the division in the main
- * loop may be replaced by a digit shift and mask.
+ * Converts a double-precision number to a fixed-lengt string of 'ilim'
+ * digits (or 'ilim1' if log10(d) has been overestimated). The
+ * denominator in David Gay's conversion algorithm is known to be a power
+ * of 2**DIGIT_BIT, and hence the division in the main loop may be
+ * replaced by a digit shift and mask.
*
* Results:
- * Returns the string of significant decimal digits, in newly
- * allocated memory.
+ * Returns the string of significant decimal digits, in newly allocated
+ * memory.
*
* Side effects:
- * Stores the location of the decimal point in '*decpt' and the
- * location of the terminal null byte in '*endPtr'.
+ * Stores the location of the decimal point in '*decpt' and the location
+ * of the terminal null byte in '*endPtr'.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-StrictBignumConversionPowD(Double* dPtr,
- /* Original number to convert */
- int convType,
- /* Type of conversion (shortest, Steele,
- E format, F format) */
- Tcl_WideUInt bw,
- /* Integer significand */
- int b2, int b5,
- /* Scale factor for the significand
- * in the numerator */
- int sd,
- /* Scale factor for the denominator */
- int k,
- /* Number of output digits before the decimal
- * point */
- int len,
- /* Number of digits to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Position of the terminal '\0'
- * at the end of the returned string */
+inline static char *
+StrictBignumConversionPowD(
+ Double *dPtr, /* Original number to convert. */
+ int convType, /* Type of conversion (shortest, Steele,
+ * E format, F format). */
+ Tcl_WideUInt bw, /* Integer significand. */
+ int b2, int b5, /* Scale factor for the significand in the
+ * numerator. */
+ int sd, /* Scale factor for the denominator. */
+ int k, /* Number of output digits before the decimal
+ * point. */
+ int len, /* Number of digits to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Position of the terminal '\0' at
+ * the end of the returned string. */
{
-
- char* retval = ckalloc(len + 1);
- /* Output buffer */
- mp_int b; /* Numerator of the fraction being converted */
- mp_digit digit; /* Current output digit */
- char* s = retval; /* Cursor in the output buffer */
- int i; /* Index in the output buffer */
+ char *retval = ckalloc(len + 1);
+ /* Output buffer. */
+ mp_int b; /* Numerator of the fraction being
+ * converted. */
+ mp_digit digit; /* Current output digit. */
+ char *s = retval; /* Cursor in the output buffer. */
+ int i; /* Index in the output buffer. */
mp_int temp;
- /*
+ /*
* b = bw * 2**b2 * 5**b5
*/
@@ -3434,7 +3461,9 @@ StrictBignumConversionPowD(Double* dPtr,
MulPow5(&b, b5, &b);
mp_mul_2d(&b, b2, &b);
- /* Adjust if the logarithm was guessed wrong */
+ /*
+ * Adjust if the logarithm was guessed wrong.
+ */
if (b.used <= sd) {
mp_mul_d(&b, 10, &b);
@@ -3443,9 +3472,9 @@ StrictBignumConversionPowD(Double* dPtr,
}
mp_init(&temp);
- /*
+ /*
* Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT)
- * by mp_digit extraction
+ * by mp_digit extraction.
*/
i = 1;
@@ -3457,35 +3486,39 @@ StrictBignumConversionPowD(Double* dPtr,
if (b.used > sd+1 || digit >= 10) {
Tcl_Panic("wrong digit!");
}
- --b.used; mp_clamp(&b);
+ --b.used;
+ mp_clamp(&b);
}
/*
* Have we converted all the requested digits?
*/
+
*s++ = '0' + digit;
if (i == ilim) {
if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) {
s = BumpUp(s, retval, &k);
- } else {
- while (*--s == '0') {
- /* do nothing */
- }
- ++s;
}
+ while (*--s == '0') {
+ /* do nothing */
+ }
+ ++s;
break;
}
-
- /* Advance to the next digit */
-
+
+ /*
+ * Advance to the next digit.
+ */
+
mp_mul_d(&b, 10, &b);
++i;
}
- /*
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
mp_clear_multi(&b, &temp, NULL);
*s = '\0';
*decpt = k;
@@ -3496,7 +3529,7 @@ StrictBignumConversionPowD(Double* dPtr,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShouldBankerRoundUp --
*
@@ -3506,17 +3539,18 @@ StrictBignumConversionPowD(Double* dPtr,
* Results:
* Returns 1 if the number needs to be rounded up, 0 otherwise.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-ShouldBankerRoundUp(mp_int* twor,
- /* 2x the remainder from thd division that
- * produced the last digit */
- mp_int* S, /* Denominator */
- int isodd) /* Flag == 1 if the last digit is odd */
+ShouldBankerRoundUp(
+ mp_int *twor, /* 2x the remainder from thd division that
+ * produced the last digit. */
+ mp_int *S, /* Denominator. */
+ int isodd) /* Flag == 1 if the last digit is odd. */
{
int r = mp_cmp_mag(twor, S);
+
switch (r) {
case MP_LT:
return 0;
@@ -3530,38 +3564,37 @@ ShouldBankerRoundUp(mp_int* twor,
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShouldBankerRoundUpToNext --
*
- * Tests whether the remainder is great enough to force rounding
- * to the next higher digit.
+ * Tests whether the remainder is great enough to force rounding to the
+ * next higher digit.
*
* Results:
* Returns 1 if the number should be rounded up, 0 otherwise.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
inline static int
-ShouldBankerRoundUpToNext(mp_int* b,
- /* Remainder from the division that produced
+ShouldBankerRoundUpToNext(
+ mp_int *b, /* Remainder from the division that produced
* the last digit. */
- mp_int* m,
- /* Numerator of the rounding tolerance */
- mp_int* S,
- /* Denominator */
- int convType,
- /* Conversion type: STEELE0 defeats
- * round-to-even. (Not sure why one would
- * want this; I coped it from Gay. FIXME */
- int isodd,
- /* 1 if the integer significand is odd */
- mp_int* temp)
- /* Work area needed for the calculation */
+ mp_int *m, /* Numerator of the rounding tolerance. */
+ mp_int *S, /* Denominator. */
+ int convType, /* Conversion type: STEELE0 defeats
+ * round-to-even. (Not sure why one would want
+ * this; I coped it from Gay). FIXME */
+ int isodd, /* 1 if the integer significand is odd. */
+ mp_int *temp) /* Work area needed for the calculation. */
{
int r;
- /* Compare b and S-m: this is the same as comparing B+m and S. */
+
+ /*
+ * Compare b and S-m: this is the same as comparing B+m and S.
+ */
+
mp_add(b, m, temp);
r = mp_cmp_mag(temp, S);
switch(r) {
@@ -3579,9 +3612,9 @@ ShouldBankerRoundUpToNext(mp_int* b,
Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!");
return 0;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ShorteningBignumConversion --
*
@@ -3592,49 +3625,38 @@ ShouldBankerRoundUpToNext(mp_int* b,
* Returns the string of digits.
*
* Side effects:
- * Stores the position of the decimal point in *decpt.
- * Stores a pointer to the end of the number in *endPtr.
+ * Stores the position of the decimal point in *decpt. Stores a pointer
+ * to the end of the number in *endPtr.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-ShorteningBignumConversion(Double* dPtr,
- /* Original number being converted */
- int convType,
- /* Conversion type */
- Tcl_WideUInt bw,
- /* Integer significand and exponent */
- int b2,
- /* Scale factor for the significand */
- int m2plus, int m2minus,
- /* Scale factors for 1/2 ulp in numerator */
- int s2, int s5,
- /* Scale factors for denominator */
- int k,
- /* Guessed position of the decimal point */
- int len,
- /* Size of the digit buffer to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Pointer to the end of the number */
+inline static char *
+ShorteningBignumConversion(
+ Double *dPtr, /* Original number being converted. */
+ int convType, /* Conversion type. */
+ Tcl_WideUInt bw, /* Integer significand and exponent. */
+ int b2, /* Scale factor for the significand. */
+ int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */
+ int s2, int s5, /* Scale factors for denominator. */
+ int k, /* Guessed position of the decimal point. */
+ int len, /* Size of the digit buffer to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char* retval = ckalloc(len+1);
- /* Buffer of digits to return */
- char* s = retval; /* Cursor in the return value */
- mp_int b; /* Numerator of the result */
- mp_int mminus; /* 1/2 ulp below the result */
- mp_int mplus; /* 1/2 ulp above the result */
- mp_int S; /* Denominator of the result */
- mp_int dig; /* Current digit of the result */
- int digit; /* Current digit of the result */
- mp_int temp; /* Work area */
- int minit = 1; /* Fudge factor for when we misguess k */
+ char *retval = ckalloc(len+1);
+ /* Buffer of digits to return. */
+ char *s = retval; /* Cursor in the return value. */
+ mp_int b; /* Numerator of the result. */
+ mp_int mminus; /* 1/2 ulp below the result. */
+ mp_int mplus; /* 1/2 ulp above the result. */
+ mp_int S; /* Denominator of the result. */
+ mp_int dig; /* Current digit of the result. */
+ int digit; /* Current digit of the result. */
+ mp_int temp; /* Work area. */
+ int minit = 1; /* Fudge factor for when we misguess k. */
int i;
int r1;
@@ -3649,10 +3671,9 @@ ShorteningBignumConversion(Double* dPtr,
MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
/*
- * Handle the case where we guess the position of the decimal point
- * wrong.
+ * Handle the case where we guess the position of the decimal point wrong.
*/
-
+
if (mp_cmp_mag(&b, &S) == MP_LT) {
mp_mul_d(&b, 10, &b);
minit = 10;
@@ -3660,7 +3681,9 @@ ShorteningBignumConversion(Double* dPtr,
--k;
}
- /* mminus = 2**m2minus * 5**m5 */
+ /*
+ * mminus = 2**m2minus * 5**m5
+ */
mp_init_set_int(&mminus, minit);
mp_mul_2d(&mminus, m2minus, &mminus);
@@ -3670,7 +3693,9 @@ ShorteningBignumConversion(Double* dPtr,
}
mp_init(&temp);
- /* Loop through the digits */
+ /*
+ * Loop through the digits.
+ */
mp_init(&dig);
i = 1;
@@ -3681,16 +3706,14 @@ ShorteningBignumConversion(Double* dPtr,
}
digit = dig.dp[0];
- /*
+ /*
* Does the current digit leave us with a remainder small enough to
* round to it?
*/
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
- if (r1 == MP_LT
- || (r1 == MP_EQ
- && convType != TCL_DD_STEELE0
- && (dPtr->w.word1 & 1) == 0)) {
+ if (r1 == MP_LT || (r1 == MP_EQ
+ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
++digit;
@@ -3705,12 +3728,12 @@ ShorteningBignumConversion(Double* dPtr,
}
/*
- * Does the current digit leave us with a remainder large enough
- * to commit to rounding up to the next higher digit?
+ * Does the current digit leave us with a remainder large enough to
+ * commit to rounding up to the next higher digit?
*/
if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType,
- dPtr->w.word1 & 1, &temp)) {
+ dPtr->w.word1 & 1, &temp)) {
++digit;
if (digit == 10) {
*s++ = '9';
@@ -3721,22 +3744,28 @@ ShorteningBignumConversion(Double* dPtr,
break;
}
- /* Have we converted all the requested digits? */
+ /*
+ * Have we converted all the requested digits?
+ */
*s++ = '0' + digit;
if (i == ilim) {
mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
- s = BumpUp(s, retval, &k);
+ s = BumpUp(s, retval, &k);
}
break;
}
- /* Advance to the next digit */
+ /*
+ * Advance to the next digit.
+ */
if (s5 > 0) {
+ /*
+ * Can possibly shorten the denominator.
+ */
- /* Can possibly shorten the denominator */
mp_mul_2d(&b, 1, &b);
mp_mul_2d(&mminus, 1, &mminus);
if (m2plus > m2minus) {
@@ -3744,17 +3773,18 @@ ShorteningBignumConversion(Double* dPtr,
}
mp_div_d(&S, 5, &S, NULL);
--s5;
- /*
- * IDEA: It might possibly be a win to fall back to
- * int64 arithmetic here if S < 2**64/10. But it's
- * a win only for a fairly narrow range of magnitudes
- * so perhaps not worth bothering. We already know that
- * we shorten the denominator by at least 1 mp_digit, perhaps
- * 2. as we do the conversion for 17 digits of significance.
+
+ /*
+ * IDEA: It might possibly be a win to fall back to int64
+ * arithmetic here if S < 2**64/10. But it's a win only for
+ * a fairly narrow range of magnitudes so perhaps not worth
+ * bothering. We already know that we shorten the
+ * denominator by at least 1 mp_digit, perhaps 2, as we do
+ * the conversion for 17 digits of significance.
* Possible savings:
* 10**26 1 trip through loop before fallback possible
* 10**27 1 trip
- * 10**28 2 trips
+ * 10**28 2 trips
* 10**29 3 trips
* 10**30 4 trips
* 10**31 5 trips
@@ -3769,7 +3799,7 @@ ShorteningBignumConversion(Double* dPtr,
* 10**40 14 trips
* 10**41 15 trips
* 10**42 16 trips
- * thereafter no gain.
+ * thereafter no gain.
*/
} else {
mp_mul_d(&b, 10, &b);
@@ -3782,11 +3812,11 @@ ShorteningBignumConversion(Double* dPtr,
++i;
}
-
- /*
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
if (m2plus > m2minus) {
mp_clear(&mplus);
}
@@ -3797,59 +3827,51 @@ ShorteningBignumConversion(Double* dPtr,
*endPtr = s;
}
return retval;
-
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* StrictBignumConversion --
*
- * Convert a floating point number to a fixed-length digit string
- * using the multiprecision method.
+ * Convert a floating point number to a fixed-length digit string using
+ * the multiprecision method.
*
* Results:
* Returns the string of digits.
*
* Side effects:
- * Stores the position of the decimal point in *decpt.
- * Stores a pointer to the end of the number in *endPtr.
+ * Stores the position of the decimal point in *decpt. Stores a pointer
+ * to the end of the number in *endPtr.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-inline static char*
-StrictBignumConversion(Double* dPtr,
- /* Original number being converted */
- int convType,
- /* Conversion type */
- Tcl_WideUInt bw,
- /* Integer significand and exponent */
- int b2, /* Scale factor for the significand */
- int s2, int s5,
- /* Scale factors for denominator */
- int k, /* Guessed position of the decimal point */
- int len, /* Size of the digit buffer to allocate */
- int ilim,
- /* Number of digits to convert if b >= s */
- int ilim1,
- /* Number of digits to convert if b < s */
- int* decpt,
- /* OUTPUT: Position of the decimal point */
- char** endPtr)
- /* OUTPUT: Pointer to the end of the number */
+inline static char *
+StrictBignumConversion(
+ Double *dPtr, /* Original number being converted. */
+ int convType, /* Conversion type. */
+ Tcl_WideUInt bw, /* Integer significand and exponent. */
+ int b2, /* Scale factor for the significand. */
+ int s2, int s5, /* Scale factors for denominator. */
+ int k, /* Guessed position of the decimal point. */
+ int len, /* Size of the digit buffer to allocate. */
+ int ilim, /* Number of digits to convert if b >= s */
+ int ilim1, /* Number of digits to convert if b < s */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char* retval = ckalloc(len+1);
- /* Buffer of digits to return */
- char* s = retval; /* Cursor in the return value */
- mp_int b; /* Numerator of the result */
- mp_int S; /* Denominator of the result */
- mp_int dig; /* Current digit of the result */
- int digit; /* Current digit of the result */
- mp_int temp; /* Work area */
- int g; /* Size of the current digit groun */
+ char *retval = ckalloc(len+1);
+ /* Buffer of digits to return. */
+ char *s = retval; /* Cursor in the return value. */
+ mp_int b; /* Numerator of the result. */
+ mp_int S; /* Denominator of the result. */
+ mp_int dig; /* Current digit of the result. */
+ int digit; /* Current digit of the result. */
+ mp_int temp; /* Work area. */
+ int g; /* Size of the current digit ground. */
int i, j;
-
+
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
@@ -3861,10 +3883,9 @@ StrictBignumConversion(Double* dPtr,
MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
/*
- * Handle the case where we guess the position of the decimal point
- * wrong.
+ * Handle the case where we guess the position of the decimal point wrong.
*/
-
+
if (mp_cmp_mag(&b, &S) == MP_LT) {
mp_mul_d(&b, 10, &b);
ilim =ilim1;
@@ -3872,7 +3893,9 @@ StrictBignumConversion(Double* dPtr,
}
mp_init(&temp);
- /* Convert the leading digit */
+ /*
+ * Convert the leading digit.
+ */
mp_init(&dig);
i = 0;
@@ -3882,19 +3905,21 @@ StrictBignumConversion(Double* dPtr,
}
digit = dig.dp[0];
- /* Is a single digit all that was requested? */
+ /*
+ * Is a single digit all that was requested?
+ */
*s++ = '0' + digit;
if (++i >= ilim) {
mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
- s = BumpUp(s, retval, &k);
+ s = BumpUp(s, retval, &k);
}
} else {
-
for (;;) {
-
- /* Shift by a group of digits. */
+ /*
+ * Shift by a group of digits.
+ */
g = ilim - i;
if (g > DIGIT_GROUP) {
@@ -3911,20 +3936,19 @@ StrictBignumConversion(Double* dPtr,
mp_mul_d(&b, dpow5[g], &b);
}
mp_mul_2d(&b, g, &b);
-
+
/*
- * As with the shortening bignum conversion, it's possible at
- * this point that we will have reduced the denominator to
- * less than 2**64/10, at which point it would be possible to
- * fall back to to int64 arithmetic. But the potential payoff
- * is tremendously less - unless we're working in F format -
- * because we know that three groups of digits will always
- * suffice for %#.17e, the longest format that doesn't introduce
- * empty precision.
+ * As with the shortening bignum conversion, it's possible at this
+ * point that we will have reduced the denominator to less than
+ * 2**64/10, at which point it would be possible to fall back to
+ * to int64 arithmetic. But the potential payoff is tremendously
+ * less - unless we're working in F format - because we know that
+ * three groups of digits will always suffice for %#.17e, the
+ * longest format that doesn't introduce empty precision.
+ *
+ * Extract the next group of digits.
*/
- /* Extract the next group of digits */
-
mp_div(&b, &S, &dig, &b);
if (dig.used > 1) {
Tcl_Panic("wrong digit!");
@@ -3932,31 +3956,35 @@ StrictBignumConversion(Double* dPtr,
digit = dig.dp[0];
for (j = g-1; j >= 0; --j) {
int t = itens[j];
+
*s++ = digit / t + '0';
digit %= t;
}
i += g;
-
- /* Have we converted all the requested digits? */
-
+
+ /*
+ * Have we converted all the requested digits?
+ */
+
if (i == ilim) {
mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
- s = BumpUp(s, retval, &k);
- } else {
- while (*--s == '0') {
- /* do nothing */
- }
- ++s;
- }
- break;
+ s = BumpUp(s, retval, &k);
+ }
+ break;
}
}
}
- /*
+ while (*--s == '0') {
+ /* do nothing */
+ }
+ ++s;
+
+ /*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
+
mp_clear_multi(&b, &temp, NULL);
*s = '\0';
*decpt = k;
@@ -3964,121 +3992,122 @@ StrictBignumConversion(Double* dPtr,
*endPtr = s;
}
return retval;
-
}
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* TclDoubleDigits --
*
- * Core of Tcl's conversion of double-precision floating point numbers
- * to decimal.
+ * Core of Tcl's conversion of double-precision floating point numbers to
+ * decimal.
*
* Results:
* Returns a newly-allocated string of digits.
*
* Side effects:
* Sets *decpt to the index of the character in the string before the
- * place that the decimal point should go. If 'endPtr' is not NULL,
- * sets endPtr to point to the terminating '\0' byte of the string.
- * Sets *sign to 1 if a minus sign should be printed with the number,
- * or 0 if a plus sign (or no sign) should appear.
+ * place that the decimal point should go. If 'endPtr' is not NULL, sets
+ * endPtr to point to the terminating '\0' byte of the string. Sets *sign
+ * to 1 if a minus sign should be printed with the number, or 0 if a plus
+ * sign (or no sign) should appear.
*
- * This function is a service routine that produces the string of digits
- * for floating-point-to-decimal conversion. It can do a number of things
+ * This function is a service routine that produces the string of digits for
+ * floating-point-to-decimal conversion. It can do a number of things
* according to the 'flags' argument. Valid values for 'flags' include:
- * TCL_DD_SHORTEST - This is the default for floating point conversion
- * if ::tcl_precision is 0. It constructs the shortest string
- * of digits that will reconvert to the given number when scanned.
+ * TCL_DD_SHORTEST - This is the default for floating point conversion if
+ * ::tcl_precision is 0. It constructs the shortest string of
+ * digits that will reconvert to the given number when scanned.
* For floating point numbers that are exactly between two
* decimal numbers, it resolves using the 'round to even' rule.
* With this value, the 'ndigits' parameter is ignored.
- * TCL_DD_STEELE - This value is not recommended and may be removed
- * in the future. It follows the conversion algorithm outlined
- * in "How to Print Floating-Point Numbers Accurately" by
- * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90,
- * pp. 112-126]. This rule has the effect of rendering 1e23
- * as 9.9999999999999999e22 - which is a 'better' approximation
- * in the sense that it will reconvert correctly even if
- * a subsequent input conversion is 'round up' or 'round down'
+ * TCL_DD_STEELE - This value is not recommended and may be removed in
+ * the future. It follows the conversion algorithm outlined in
+ * "How to Print Floating-Point Numbers Accurately" by Guy
+ * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90,
+ * pp. 112-126]. This rule has the effect of rendering 1e23 as
+ * 9.9999999999999999e22 - which is a 'better' approximation in
+ * the sense that it will reconvert correctly even if a
+ * subsequent input conversion is 'round up' or 'round down'
* rather than 'round to nearest', but is surprising otherwise.
- * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e
- * format conversion (or for default floating->string if
- * tcl_precision is not 0). It constructs a string of at most
- * 'ndigits' digits, choosing the one that is closest to the
- * given number (and resolving ties with 'round to even').
- * It is allowed to return fewer than 'ndigits' if the number
- * converts exactly; if the TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG
- * is supplied instead, it also returns fewer digits if the
- * shorter string will still reconvert to the given input number.
- * In any case, strings of trailing zeroes are suppressed.
- * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f
- * format conversion. It requests that conversion proceed until
+ * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format
+ * conversion (or for default floating->string if tcl_precision
+ * is not 0). It constructs a string of at most 'ndigits' digits,
+ * choosing the one that is closest to the given number (and
+ * resolving ties with 'round to even'). It is allowed to return
+ * fewer than 'ndigits' if the number converts exactly; if the
+ * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it
+ * also returns fewer digits if the shorter string will still
+ * reconvert without loss to the given input number. In any case,
+ * strings of trailing zeroes are suppressed.
+ * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format
+ * conversion. It requests that conversion proceed until
* 'ndigits' digits after the decimal point have been converted.
- * It is possible for this format to result in a zero-length
- * string if the number is sufficiently small. Again, it
- * is permissible for TCL_DD_F_FORMAT to return fewer digits
- * for a number that converts exactly, and changing the
- * argument to TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow
- * the routine also to return fewer digits if the shorter string
- * will still reconvert without loss to the given input number.
- * Strings of trailing zeroes are suppressed.
- *
- * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag
- * requires all calculations to be done in exact arithmetic. Normally,
- * E and F format with fewer than about 14 digits will be done with
- * a quick floating point approximation and fall back on the exact
- * arithmetic only if the input number is close enough to the
- * midpoint between two decimal strings that more precision is needed
- * to resolve which string is correct.
- *
- * The value stored in the 'decpt' argument on return may be negative
- * (indicating that the decimal point falls to the left of the string)
- * or greater than the length of the string. In addition, the value -9999
- * is used as a sentinel to indicate that the string is one of the special
- * values "Infinity" and "NaN", and that no decimal point should be inserted.
- *
- *-----------------------------------------------------------------------------
+ * It is possible for this format to result in a zero-length
+ * string if the number is sufficiently small. Again, it is
+ * permissible for TCL_DD_F_FORMAT to return fewer digits for a
+ * number that converts exactly, and changing the argument to
+ * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine
+ * also to return fewer digits if the shorter string will still
+ * reconvert without loss to the given input number. Strings of
+ * trailing zeroes are suppressed.
+ *
+ * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires
+ * all calculations to be done in exact arithmetic. Normally, E and F
+ * format with fewer than about 14 digits will be done with a quick
+ * floating point approximation and fall back on the exact arithmetic
+ * only if the input number is close enough to the midpoint between two
+ * decimal strings that more precision is needed to resolve which string
+ * is correct.
+ *
+ * The value stored in the 'decpt' argument on return may be negative
+ * (indicating that the decimal point falls to the left of the string) or
+ * greater than the length of the string. In addition, the value -9999 is used
+ * as a sentinel to indicate that the string is one of the special values
+ * "Infinity" and "NaN", and that no decimal point should be inserted.
+ *
+ *----------------------------------------------------------------------
*/
-char*
-TclDoubleDigits(double dv, /* Number to convert */
- int ndigits, /* Number of digits requested */
- int flags, /* Conversion flags */
- int* decpt, /* OUTPUT: Position of the decimal point */
- int* sign, /* OUTPUT: 1 if the result is negative */
- char** endPtr) /* OUTPUT: If not NULL, receives a pointer
- * to one character beyond the end
- * of the returned string */
+
+char *
+TclDoubleDigits(
+ double dv, /* Number to convert. */
+ int ndigits, /* Number of digits requested. */
+ int flags, /* Conversion flags. */
+ int *decpt, /* OUTPUT: Position of the decimal point. */
+ int *sign, /* OUTPUT: 1 if the result is negative. */
+ char **endPtr) /* OUTPUT: If not NULL, receives a pointer to
+ * one character beyond the end of the
+ * returned string. */
{
int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK);
- /* Type of conversion being performed
- * TCL_DD_SHORTEST0
- * TCL_DD_STEELE0
- * TCL_DD_E_FORMAT
- * TCL_DD_F_FORMAT */
- Double d; /* Union for deconstructing doubles */
- Tcl_WideUInt bw; /* Integer significand */
+ /* Type of conversion being performed:
+ * TCL_DD_SHORTEST0, TCL_DD_STEELE0,
+ * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */
+ Double d; /* Union for deconstructing doubles. */
+ Tcl_WideUInt bw; /* Integer significand. */
int be; /* Power of 2 by which b must be multiplied */
- int bbits; /* Number of bits needed to represent b */
+ int bbits; /* Number of bits needed to represent b. */
int denorm; /* Flag == 1 iff the input number was
- * denormalized */
- int k; /* Estimate of floor(log10(d)) */
- int k_check; /* Flag == 1 if d is near enough to a
- * power of ten that k must be checked */
+ * denormalized. */
+ int k; /* Estimate of floor(log10(d)). */
+ int k_check; /* Flag == 1 if d is near enough to a power of
+ * ten that k must be checked. */
int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and
- * denominator of intermediate results */
- int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number
- * to convert if log10(d) has been
- * overestimated */
- char* retval; /* Return value from this function */
+ * denominator of intermediate results. */
+ int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number to
+ * convert if log10(d) has been
+ * overestimated. */
+ char *retval; /* Return value from this function. */
int i = -1;
- /* Put the input number into a union for bit-whacking */
+ /*
+ * Put the input number into a union for bit-whacking.
+ */
d.d = dv;
- /*
+ /*
* Handle the cases of negative numbers (by taking the absolute value:
* this includes -Inf and -NaN!), infinity, Not a Number, and zero.
*/
@@ -4091,12 +4120,12 @@ TclDoubleDigits(double dv, /* Number to convert */
return FormatZero(decpt, endPtr);
}
- /*
+ /*
* Unpack the floating point into a wide integer and an exponent.
- * Determine the number of bits that the big integer requires, and
- * compute a quick approximation (which may be one too high) of
- * ceil(log10(d.d)).
+ * Determine the number of bits that the big integer requires, and compute
+ * a quick approximation (which may be one too high) of ceil(log10(d.d)).
*/
+
denorm = ((d.w.word0 & EXP_MASK) == 0);
DoubleToExpAndSig(d.d, &bw, &be, &bbits);
k = ApproximateLog10(bw, be, bbits);
@@ -4104,60 +4133,59 @@ TclDoubleDigits(double dv, /* Number to convert */
/* At this point, we have:
* d is the number to convert.
- * bw are significand and exponent: d == bw*2**be,
+ * bw are significand and exponent: d == bw*2**be,
* bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits
- * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0
- * if we know that k is exactly ceil(log10(d)) and 1 if we need to
- * check.
- * We want a rational number
+ * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 if we
+ * know that k is exactly ceil(log10(d)) and 1 if we need to check.
+ * We want a rational number
* r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5),
* with b2, b5, s2, s5 >= 0. Note that the most significant decimal
- * digit is floor(r) and that successive digits can be obtained
- * by setting r <- 10*floor(r) (or b <= 10 * (b % S)).
- * Find appropriate b2, b5, s2, s5.
+ * digit is floor(r) and that successive digits can be obtained by
+ * setting r <- 10*floor(r) (or b <= 10 * (b % S)). Find appropriate
+ * b2, b5, s2, s5.
*/
ComputeScale(be, k, &b2, &b5, &s2, &s5);
/*
- * Correct an incorrect caller-supplied 'ndigits'.
- * Also determine:
+ * Correct an incorrect caller-supplied 'ndigits'. Also determine:
* i = The maximum number of decimal digits that will be returned in the
* formatted string. This is k + 1 + ndigits for F format, 18 for
- * shortest and Steele, and ndigits for E format.
- * ilim = The number of significant digits to convert if
- * k has been guessed correctly. This is -1 for shortest and Steele
- * (which stop when all significance has been lost), 'ndigits'
- * for E format, and 'k + 1 + ndigits' for F format.
- * ilim1 = The minimum number of significant digits to convert if
- * k has been guessed 1 too high. This, too, is -1 for shortest
- * and Steele, and 'ndigits' for E format, but it's 'ndigits-1'
- * for F format.
+ * shortest and Steele, and ndigits for E format.
+ * ilim = The number of significant digits to convert if k has been
+ * guessed correctly. This is -1 for shortest and Steele (which
+ * stop when all significance has been lost), 'ndigits' for E
+ * format, and 'k + 1 + ndigits' for F format.
+ * ilim1 = The minimum number of significant digits to convert if k has
+ * been guessed 1 too high. This, too, is -1 for shortest and
+ * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F
+ * format.
*/
SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1);
- /*
- * Try to do low-precision conversion in floating point rather
- * than resorting to expensive multiprecision arithmetic
+ /*
+ * Try to do low-precision conversion in floating point rather than
+ * resorting to expensive multiprecision arithmetic.
*/
+
if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) {
- if ((retval = QuickConversion(d.d, k, k_check, flags,
- i, ilim, ilim1,
- decpt, endPtr)) != NULL) {
+ retval = QuickConversion(d.d, k, k_check, flags, i, ilim, ilim1,
+ decpt, endPtr);
+ if (retval != NULL) {
return retval;
}
}
- /*
- * For shortening conversions, determine the upper and lower bounds
- * for the remainder at which we can stop.
- * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the
- * high side, and
- * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the
- * low side.
- * We may need to increase s2 to put m2plus, m2minus, b2 over a
- * common denominator.
+ /*
+ * For shortening conversions, determine the upper and lower bounds for
+ * the remainder at which we can stop.
+ * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the high
+ * side, and
+ * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low
+ * side.
+ * We may need to increase s2 to put m2plus, m2minus, b2 over a common
+ * denominator.
*/
if (flags & TCL_DD_SHORTEN_FLAG) {
@@ -4166,11 +4194,11 @@ TclDoubleDigits(double dv, /* Number to convert */
int m5 = b5;
int len = i;
- /*
- * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5)
- * is 1/2 unit in the least significant place of the floating
- * point number.
+ /*
+ * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit
+ * in the least significant place of the floating point number.
*/
+
if (denorm) {
i = be + EXPONENT_BIAS + (FP_PRECISION-1);
} else {
@@ -4179,16 +4207,18 @@ TclDoubleDigits(double dv, /* Number to convert */
b2 += i;
s2 += i;
- /*
+ /*
* Reduce the fractions to lowest terms, since the above calculation
- * may have left excess powers of 2 in numerator and denominator
+ * may have left excess powers of 2 in numerator and denominator.
*/
+
CastOutPowersOf2(&b2, &m2minus, &s2);
/*
* In the special case where bw==1, the nearest floating point number
* to it on the low side is 1/4 ulp below it. Adjust accordingly.
*/
+
m2plus = m2minus;
if (!denorm && bw == 1) {
++b2;
@@ -4196,60 +4226,56 @@ TclDoubleDigits(double dv, /* Number to convert */
++m2plus;
}
- if (s5+1 < N_LOG2POW5
- && s2+1 + log2pow5[s5+1] <= 64) {
+ if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) {
/*
- * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit
- * word, then all our intermediate calculations can be done
- * using exact 64-bit arithmetic with no need for expensive
- * multiprecision operations. (This will be true for all numbers
- * in the range [1.0e-3 .. 1.0e+24]).
+ * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
+ * then all our intermediate calculations can be done using exact
+ * 64-bit arithmetic with no need for expensive multiprecision
+ * operations. (This will be true for all numbers in the range
+ * [1.0e-3 .. 1.0e+24]).
*/
- return ShorteningInt64Conversion(&d, convType, bw, b2, b5,
- m2plus, m2minus, m5,
- s2, s5, k, len, ilim, ilim1,
- decpt, endPtr);
+ return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus,
+ m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
- * The denominator is a power of 2, so we can replace division
- * by digit shifts. First we round up s2 to a multiple of
- * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch
- * into a version of the comparison that's specialized for
- * the 'power of mp_digit in the denominator' case.
+ * The denominator is a power of 2, so we can replace division by
+ * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
+ * and adjust m2 and b2 accordingly. Then we launch into a version
+ * of the comparison that's specialized for the 'power of mp_digit
+ * in the denominator' case.
*/
+
if (s2 % DIGIT_BIT != 0) {
int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+
b2 += delta;
m2plus += delta;
m2minus += delta;
s2 += delta;
}
return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5,
- m2plus, m2minus, m5,
- s2/DIGIT_BIT, k, len,
- ilim, ilim1, decpt, endPtr);
+ m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1,
+ decpt, endPtr);
} else {
-
- /*
- * Alas, there's no helpful special case; use full-up
- * bignum arithmetic for the conversion
+ /*
+ * Alas, there's no helpful special case; use full-up bignum
+ * arithmetic for the conversion.
*/
- return ShorteningBignumConversion(&d, convType, bw,
- b2, m2plus, m2minus,
- s2, s5, k, len,
- ilim, ilim1, decpt, endPtr);
-
+ return ShorteningBignumConversion(&d, convType, bw, b2, m2plus,
+ m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
}
-
} else {
-
- /* Non-shortening conversion */
+ /*
+ * Non-shortening conversion.
+ */
int len = i;
- /* Reduce numerator and denominator to lowest terms */
+ /*
+ * Reduce numerator and denominator to lowest terms.
+ */
if (b2 >= s2 && s2 > 0) {
b2 -= s2; s2 = 0;
@@ -4257,48 +4283,46 @@ TclDoubleDigits(double dv, /* Number to convert */
s2 -= b2; b2 = 0;
}
- if (s5+1 < N_LOG2POW5
- && s2+1 + log2pow5[s5+1] <= 64) {
+ if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) {
/*
- * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit
- * word, then all our intermediate calculations can be done
- * using exact 64-bit arithmetic with no need for expensive
- * multiprecision operations.
+ * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
+ * then all our intermediate calculations can be done using exact
+ * 64-bit arithmetic with no need for expensive multiprecision
+ * operations.
*/
- return StrictInt64Conversion(&d, convType, bw, b2, b5,
- s2, s5, k, len, ilim, ilim1,
- decpt, endPtr);
-
+ return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k,
+ len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
- * The denominator is a power of 2, so we can replace division
- * by digit shifts. First we round up s2 to a multiple of
- * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch
- * into a version of the comparison that's specialized for
- * the 'power of mp_digit in the denominator' case.
+ * The denominator is a power of 2, so we can replace division by
+ * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
+ * and adjust m2 and b2 accordingly. Then we launch into a version
+ * of the comparison that's specialized for the 'power of mp_digit
+ * in the denominator' case.
*/
+
if (s2 % DIGIT_BIT != 0) {
int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+
b2 += delta;
s2 += delta;
}
return StrictBignumConversionPowD(&d, convType, bw, b2, b5,
- s2/DIGIT_BIT, k, len,
- ilim, ilim1, decpt, endPtr);
+ s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
- * There are no helpful special cases, but at least we know
- * in advance how many digits we will convert. We can run the
- * conversion in steps of DIGIT_GROUP digits, so as to
- * have many fewer mp_int divisions.
+ * There are no helpful special cases, but at least we know in
+ * advance how many digits we will convert. We can run the
+ * conversion in steps of DIGIT_GROUP digits, so as to have many
+ * fewer mp_int divisions.
*/
- return StrictBignumConversion(&d, convType, bw, b2, s2, s5,
- k, len, ilim, ilim1, decpt, endPtr);
+
+ return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k,
+ len, ilim, ilim1, decpt, endPtr);
}
- }
+ }
}
-
/*
*----------------------------------------------------------------------
@@ -4326,14 +4350,12 @@ TclInitDoubleConversion(void)
int x;
Tcl_WideUInt u;
double d;
-
#ifdef IEEE_FLOATING_POINT
union {
double dv;
Tcl_WideUInt iv;
} bitwhack;
#endif
-
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
@@ -4348,8 +4370,7 @@ TclInitDoubleConversion(void)
maxpow10_wide = (int)
floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
- pow10_wide = (Tcl_WideUInt *)
- ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
+ pow10_wide = ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
u = 1;
for (i = 0; i < maxpow10_wide; ++i) {
pow10_wide[i] = u;
@@ -4358,8 +4379,8 @@ TclInitDoubleConversion(void)
pow10_wide[i] = u;
/*
- * Determine how many bits of precision a double has, and how many
- * decimal digits that represents.
+ * Determine how many bits of precision a double has, and how many decimal
+ * digits that represents.
*/
if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) {
@@ -4370,8 +4391,8 @@ TclInitDoubleConversion(void)
d = 1.0;
/*
- * Initialize a table of powers of ten that can be exactly represented
- * in a double.
+ * Initialize a table of powers of ten that can be exactly represented in
+ * a double.
*/
x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0));
@@ -4457,7 +4478,7 @@ TclFinalizeDoubleConversion(void)
{
int i;
- ckfree((char *) pow10_wide);
+ ckfree(pow10_wide);
for (i=0; i<9; ++i) {
mp_clear(pow5 + i);
}
@@ -4483,9 +4504,9 @@ TclFinalizeDoubleConversion(void)
int
Tcl_InitBignumFromDouble(
- Tcl_Interp *interp, /* For error message */
- double d, /* Number to convert */
- mp_int *b) /* Place to store the result */
+ Tcl_Interp *interp, /* For error message. */
+ double d, /* Number to convert. */
+ mp_int *b) /* Place to store the result. */
{
double fract;
int expt;
@@ -4539,7 +4560,7 @@ Tcl_InitBignumFromDouble(
double
TclBignumToDouble(
- mp_int *a) /* Integer to convert. */
+ const mp_int *a) /* Integer to convert. */
{
mp_int b;
int bits, shift, i;
@@ -4597,9 +4618,9 @@ TclBignumToDouble(
return -r;
}
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* TclCeil --
*
@@ -4609,12 +4630,12 @@ TclBignumToDouble(
* Results:
* Returns the floating point number.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
double
TclCeil(
- mp_int *a) /* Integer to convert. */
+ const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
@@ -4654,24 +4675,24 @@ TclCeil(
mp_clear(&b);
return r;
}
-
+
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* TclFloor --
*
- * Computes the largest floating point number less than or equal to
- * the mp_int argument.
+ * Computes the largest floating point number less than or equal to the
+ * mp_int argument.
*
* Results:
* Returns the floating point value.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
double
TclFloor(
- mp_int *a) /* Integer to convert. */
+ const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
@@ -4727,8 +4748,8 @@ TclFloor(
static double
BignumToBiasedFrExp(
- mp_int *a, /* Integer to convert */
- int *machexp) /* Power of two */
+ const mp_int *a, /* Integer to convert. */
+ int *machexp) /* Power of two. */
{
mp_int b;
int bits;
@@ -4792,8 +4813,8 @@ BignumToBiasedFrExp(
static double
Pow10TimesFrExp(
- int exponent, /* Power of 10 to multiply by */
- double fraction, /* Significand of multiplicand */
+ int exponent, /* Power of 10 to multiply by. */
+ double fraction, /* Significand of multiplicand. */
int *machexp) /* On input, exponent of multiplicand. On
* output, exponent of result. */
{
@@ -4803,7 +4824,7 @@ Pow10TimesFrExp(
if (exponent > 0) {
/*
- * Multiply by 10**exponent
+ * Multiply by 10**exponent.
*/
retval = frexp(retval * pow10vals[exponent&0xf], &j);
@@ -4816,7 +4837,7 @@ Pow10TimesFrExp(
}
} else if (exponent < 0) {
/*
- * Divide by 10**-exponent
+ * Divide by 10**-exponent.
*/
retval = frexp(retval / pow10vals[(-exponent) & 0xf], &j);
@@ -4925,26 +4946,27 @@ TclFormatNaN(
*
* Nokia770Twiddle --
*
- * Transpose the two words of a number for Nokia 770 floating
- * point handling.
+ * Transpose the two words of a number for Nokia 770 floating point
+ * handling.
*
*----------------------------------------------------------------------
*/
-
+#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
- Tcl_WideUInt w) /* Number to transpose */
+ Tcl_WideUInt w) /* Number to transpose. */
{
return (((w >> 32) & 0xffffffff) | (w << 32));
}
+#endif
/*
*----------------------------------------------------------------------
*
* TclNokia770Doubles --
*
- * Transpose the two words of a number for Nokia 770 floating
- * point handling.
+ * Transpose the two words of a number for Nokia 770 floating point
+ * handling.
*
*----------------------------------------------------------------------
*/
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 13dda54..0f6eff7 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -38,6 +38,15 @@
#include "tommath.h"
/*
+ * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5.
+ * This is an escape hatch in case the changes have some unexpected unwelcome
+ * impact on performance. If things go well, this mechanism can go away when
+ * post-8.6 development begins.
+ */
+
+#define COMPAT 0
+
+/*
* Prototypes for functions defined later in this file:
*/
@@ -53,8 +62,14 @@ static void AppendUtfToUtfRep(Tcl_Obj *objPtr,
const char *bytes, int numBytes);
static void DupStringInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
+static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, int numChars);
+static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
+ const char *bytes, int numBytes,
+ int numAppendChars);
static void FillUnicodeRep(Tcl_Obj *objPtr);
static void FreeStringInternalRep(Tcl_Obj *objPtr);
+static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag);
static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed);
static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
@@ -67,7 +82,7 @@ static void UpdateStringOfString(Tcl_Obj *objPtr);
* functions that can be invoked by generic object code.
*/
-Tcl_ObjType tclStringType = {
+const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
@@ -95,43 +110,40 @@ typedef struct String {
* means that there is a valid Unicode rep, or
* that the number of UTF bytes == the number
* of chars. */
- size_t allocated; /* The amount of space actually allocated for
+ int allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
- size_t uallocated; /* The amount of space actually allocated for
- * the Unicode string (minus 2 bytes for the
- * termination char). */
+ int maxChars; /* Max number of chars that can fit in the
+ * space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
- Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size
- * of this field depends on the 'uallocated'
+ Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size
+ * of this field depends on the 'maxChars'
* field above. */
} String;
#define STRING_MAXCHARS \
- (1 + (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)))
-#define STRING_UALLOC(numChars) \
- ((numChars) * sizeof(Tcl_UniChar))
-#define STRING_SIZE(ualloc) \
- ((unsigned) ((ualloc) \
- ? (sizeof(String) - sizeof(Tcl_UniChar) + (ualloc)) \
- : sizeof(String)))
+ (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar))
+#define STRING_SIZE(numChars) \
+ (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar)))
#define stringCheckLimits(numChars) \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
STRING_MAXCHARS); \
}
+#define stringAttemptAlloc(numChars) \
+ (String *) attemptckalloc((unsigned) STRING_SIZE(numChars) )
+#define stringAlloc(numChars) \
+ (String *) ckalloc((unsigned) STRING_SIZE(numChars) )
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((char *) ptr, \
- (unsigned) STRING_SIZE(STRING_UALLOC(numChars)) )
+ (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((char *) ptr, \
- (unsigned) STRING_SIZE(STRING_UALLOC(numChars)) )
+ (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr))
-
+
/*
* TCL STRING GROWTH ALGORITHM
*
@@ -171,20 +183,76 @@ typedef struct String {
#endif
static void
+GrowStringBuffer(
+ Tcl_Obj *objPtr,
+ int needed,
+ int flag)
+{
+ /*
+ * Pre-conditions:
+ * objPtr->typePtr == &tclStringType
+ * needed > stringPtr->allocated
+ * flag || objPtr->bytes != NULL
+ */
+
+ String *stringPtr = GET_STRING(objPtr);
+ char *ptr = NULL;
+ int attempt;
+
+ if (objPtr->bytes == tclEmptyStringRep) {
+ objPtr->bytes = NULL;
+ }
+ if (flag == 0 || stringPtr->allocated > 0) {
+ attempt = 2 * needed;
+ if (attempt >= 0) {
+ ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
+ }
+ if (ptr == NULL) {
+ /*
+ * Take care computing the amount of modest growth to avoid
+ * overflow into invalid argument values for attempt.
+ */
+
+ unsigned int limit = INT_MAX - needed;
+ unsigned int extra = needed - objPtr->length + TCL_GROWTH_MIN_ALLOC;
+ int growth = (int) ((extra > limit) ? limit : extra);
+
+ attempt = needed + growth;
+ ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
+ }
+ }
+ if (ptr == NULL) {
+ /*
+ * First allocation - just big enough; or last chance fallback.
+ */
+
+ attempt = needed;
+ ptr = ckrealloc(objPtr->bytes, attempt + 1);
+ }
+ objPtr->bytes = ptr;
+ stringPtr->allocated = attempt;
+}
+
+static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
int needed)
{
- /* Pre-conditions:
- * objPtr->typePtr == &tclStringType
- * STRING_UALLOC(needed) > stringPtr->uallocated
- * needed < STRING_MAXCHARS
+ /*
+ * Pre-conditions:
+ * objPtr->typePtr == &tclStringType
+ * needed > stringPtr->maxChars
+ * needed < STRING_MAXCHARS
*/
+
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
int attempt;
- if (stringPtr->uallocated > 0) {
- /* Subsequent appends - apply the growth algorithm. */
+ if (stringPtr->maxChars > 0) {
+ /*
+ * Subsequent appends - apply the growth algorithm.
+ */
+
attempt = 2 * needed;
if (attempt >= 0 && attempt <= STRING_MAXCHARS) {
ptr = stringAttemptRealloc(stringPtr, attempt);
@@ -194,24 +262,28 @@ GrowUnicodeBuffer(
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
+
unsigned int limit = STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
+ TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar);
int growth = (int) ((extra > limit) ? limit : extra);
+
attempt = needed + growth;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
}
if (ptr == NULL) {
- /* First allocation - just big enough; or last chance fallback. */
+ /*
+ * First allocation - just big enough; or last chance fallback.
+ */
+
attempt = needed;
ptr = stringRealloc(stringPtr, attempt);
}
stringPtr = ptr;
- stringPtr->uallocated = STRING_UALLOC(attempt);
+ stringPtr->maxChars = attempt;
SET_STRING(objPtr, stringPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -261,7 +333,7 @@ Tcl_NewStringObj(
* negative, use bytes up to the first NUL
* byte. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
@@ -314,7 +386,7 @@ Tcl_DbNewStringObj(
int line) /* Line number in the source file; used for
* debugging. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
@@ -328,7 +400,7 @@ Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- register int length, /* The number of bytes to copy from "bytes"
+ int length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
@@ -397,64 +469,50 @@ Tcl_GetCharLength(
* of. */
{
String *stringPtr;
-
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ int numChars;
/*
- * If numChars is unknown, then calculate the number of characaters while
- * populating the Unicode string.
+ * Optimize the case where we're really dealing with a bytearray object
+ * without string representation; we don't need to convert to a string to
+ * perform the get-length operation.
*/
- if (stringPtr->numChars == -1) {
- register int i = objPtr->length;
- register unsigned char *str = (unsigned char *) objPtr->bytes;
+ if (TclIsPureByteArray(objPtr)) {
+ int length;
- /*
- * This is a speed sensitive function, so run specially over the
- * string to count continuous ascii characters before resorting to the
- * Tcl_NumUtfChars call. This is a long form of:
- stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length);
- *
- * TODO: Consider macro-izing this.
- */
+ (void) Tcl_GetByteArrayFromObj(objPtr, &length);
+ return length;
+ }
- while (i && (*str < 0xC0)) {
- i--;
- str++;
- }
- stringPtr->numChars = objPtr->length - i;
- if (i) {
- stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
- + (objPtr->length - i), i);
- }
+ /*
+ * OK, need to work with the object as a string.
+ */
- if (stringPtr->numChars == objPtr->length) {
- /*
- * Since we've just calculated the number of chars, and all UTF
- * chars are 1-byte long, we don't need to store the unicode
- * string.
- */
+ SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+ numChars = stringPtr->numChars;
- stringPtr->hasUnicode = 0;
- } else {
- /*
- * Since we've just calucalated the number of chars, and not all
- * UTF chars are 1-byte long, go ahead and populate the unicode
- * string.
- */
+ /*
+ * If numChars is unknown, compute it.
+ */
- FillUnicodeRep(objPtr);
+ if (numChars == -1) {
+ TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
+ stringPtr->numChars = numChars;
+#if COMPAT
+ if (numChars < objPtr->length) {
/*
- * We need to fetch the pointer again because we have just
- * reallocated the structure to make room for the Unicode data.
+ * Since we've just computed the number of chars, and not all UTF
+ * chars are 1-byte long, go ahead and populate the unicode
+ * string.
*/
- stringPtr = GET_STRING(objPtr);
+ FillUnicodeRep(objPtr);
}
+#endif
}
- return stringPtr->numChars;
+ return numChars;
}
/*
@@ -480,39 +538,42 @@ Tcl_GetUniChar(
* from. */
int index) /* Get the index'th Unicode character. */
{
- Tcl_UniChar unichar;
String *stringPtr;
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ /*
+ * Optimize the case where we're really dealing with a bytearray object
+ * without string representation; we don't need to convert to a string to
+ * perform the indexing operation.
+ */
- if (stringPtr->numChars == -1) {
- /*
- * We haven't yet calculated the length, so we don't have the Unicode
- * str. We need to know the number of chars before we can do indexing.
- */
+ if (TclIsPureByteArray(objPtr)) {
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
- Tcl_GetCharLength(objPtr);
+ return (Tcl_UniChar) bytes[index];
+ }
- /*
- * We need to fetch the pointer again because we may have just
- * reallocated the structure.
- */
+ /*
+ * OK, need to work with the object as a string.
+ */
+
+ SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
if (stringPtr->hasUnicode == 0) {
/*
- * All of the characters in the Utf string are 1 byte chars, so we
- * don't store the unicode char. We get the Utf string and convert the
- * index'th byte to a Unicode character.
+ * If numChars is unknown, compute it.
*/
- unichar = (Tcl_UniChar) objPtr->bytes[index];
- } else {
- unichar = stringPtr->unicode[index];
+ if (stringPtr->numChars == -1) {
+ TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ }
+ if (stringPtr->numChars == objPtr->length) {
+ return (Tcl_UniChar) objPtr->bytes[index];
+ }
+ FillUnicodeRep(objPtr);
+ stringPtr = GET_STRING(objPtr);
}
- return unichar;
+ return stringPtr->unicode[index];
}
/*
@@ -539,30 +600,7 @@ Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the unicode string
* for. */
{
- String *stringPtr;
-
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
-
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
- /*
- * We haven't yet calculated the length, or all of the characters in
- * the Utf string are 1 byte chars (so we didn't store the unicode
- * str). Since this function must return a unicode string, and one has
- * not yet been stored, force the Unicode to be calculated and stored
- * now.
- */
-
- FillUnicodeRep(objPtr);
-
- /*
- * We need to fetch the pointer again because we have just reallocated
- * the structure to make room for the Unicode data.
- */
-
- stringPtr = GET_STRING(objPtr);
- }
- return stringPtr->unicode;
+ return Tcl_GetUnicodeFromObj(objPtr, NULL);
}
/*
@@ -597,22 +635,8 @@ Tcl_GetUnicodeFromObj(
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
- /*
- * We haven't yet calculated the length, or all of the characters in
- * the Utf string are 1 byte chars (so we didn't store the unicode
- * str). Since this function must return a unicode string, and one has
- * not yet been stored, force the Unicode to be calculated and stored
- * now.
- */
-
+ if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
-
- /*
- * We need to fetch the pointer again because we have just reallocated
- * the structure to make room for the Unicode data.
- */
-
stringPtr = GET_STRING(objPtr);
}
@@ -650,49 +674,50 @@ Tcl_GetRange(
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
-
- if (stringPtr->numChars == -1) {
- /*
- * We haven't yet calculated the length, so we don't have the Unicode
- * str. We need to know the number of chars before we can do indexing.
- */
-
- Tcl_GetCharLength(objPtr);
+ /*
+ * Optimize the case where we're really dealing with a bytearray object
+ * without string representation; we don't need to convert to a string to
+ * perform the substring operation.
+ */
- /*
- * We need to fetch the pointer again because we may have just
- * reallocated the structure.
- */
+ if (TclIsPureByteArray(objPtr)) {
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
- stringPtr = GET_STRING(objPtr);
+ return Tcl_NewByteArrayObj(bytes+first, last-first+1);
}
- if (objPtr->bytes && (stringPtr->numChars == objPtr->length)) {
- char *str = TclGetString(objPtr);
+ /*
+ * OK, need to work with the object as a string.
+ */
+ SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+
+ if (stringPtr->hasUnicode == 0) {
/*
- * All of the characters in the Utf string are 1 byte chars, so we
- * don't store the unicode char. Create a new string object containing
- * the specified range of chars.
+ * If numChars is unknown, compute it.
*/
- newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);
+ if (stringPtr->numChars == -1) {
+ TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ }
+ if (stringPtr->numChars == objPtr->length) {
+ newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1);
- /*
- * Since we know the new string only has 1-byte chars, we can set it's
- * numChars field.
- */
+ /*
+ * Since we know the char length of the result, store it.
+ */
- SetStringFromAny(NULL, newObjPtr);
- stringPtr = GET_STRING(newObjPtr);
- stringPtr->numChars = last-first+1;
- } else {
- newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first,
- last-first+1);
+ SetStringFromAny(NULL, newObjPtr);
+ stringPtr = GET_STRING(newObjPtr);
+ stringPtr->numChars = newObjPtr->length;
+ return newObjPtr;
+ }
+ FillUnicodeRep(objPtr);
+ stringPtr = GET_STRING(objPtr);
}
- return newObjPtr;
+
+ return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
}
/*
@@ -718,10 +743,10 @@ Tcl_GetRange(
void
Tcl_SetStringObj(
- register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
- register int length) /* The number of bytes to copy from "bytes"
+ int length) /* The number of bytes to copy from "bytes"
* when initializing the object. If negative,
* use bytes up to the first NUL byte.*/
{
@@ -734,14 +759,13 @@ Tcl_SetStringObj(
*/
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
/*
* Free any old string rep, then set the string rep to a copy of the
* length bytes starting at "bytes".
*/
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
@@ -773,9 +797,9 @@ Tcl_SetStringObj(
void
Tcl_SetObjLength(
- register Tcl_Obj *objPtr, /* Pointer to object. This object must not
+ Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
- register int length) /* Number of bytes desired for string
+ int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
@@ -783,60 +807,42 @@ Tcl_SetObjLength(
if (length < 0) {
/*
- * Setting to a negative length is nonsense. This is probably the
+ * Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
+
Tcl_Panic("Tcl_SetObjLength: negative length requested: "
"%d (integer overflow?)", length);
}
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
}
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ if (objPtr->bytes && objPtr->length == length) {
+ return;
+ }
- /*
- * Check that we're not extending a pure unicode string.
- */
+ SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
- if ((size_t)length > stringPtr->allocated &&
- (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
+ if (objPtr->bytes != NULL) {
/*
- * Not enough space in current string. Reallocate the string space and
- * free the old string.
+ * Change length of an existing string rep.
*/
-
- if (objPtr->bytes != tclEmptyStringRep) {
- objPtr->bytes = ckrealloc((char *) objPtr->bytes,
- (unsigned) (length + 1));
- } else {
- char *newBytes = ckalloc((unsigned) (length+1));
-
- if (objPtr->bytes != NULL && objPtr->length != 0) {
- memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length);
- Tcl_InvalidateStringRep(objPtr);
+ if (length > stringPtr->allocated) {
+ /*
+ * Need to enlarge the buffer.
+ */
+ if (objPtr->bytes == tclEmptyStringRep) {
+ objPtr->bytes = ckalloc(length + 1);
+ } else {
+ objPtr->bytes = ckrealloc(objPtr->bytes, length + 1);
}
- objPtr->bytes = newBytes;
+ stringPtr->allocated = length;
}
- stringPtr->allocated = length;
- /*
- * Invalidate the unicode data.
- */
-
- stringPtr->hasUnicode = 0;
- }
-
- if (objPtr->bytes != NULL) {
objPtr->length = length;
- if (objPtr->bytes != tclEmptyStringRep) {
- /*
- * Ensure the string is NUL-terminated.
- */
-
- objPtr->bytes[length] = 0;
- }
+ objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
@@ -849,24 +855,25 @@ Tcl_SetObjLength(
* Changing length of pure unicode string.
*/
- size_t uallocated = STRING_UALLOC(length);
-
stringCheckLimits(length);
- if (uallocated > stringPtr->uallocated) {
+ if (length > stringPtr->maxChars) {
stringPtr = stringRealloc(stringPtr, length);
SET_STRING(objPtr, stringPtr);
- stringPtr->uallocated = uallocated;
+ stringPtr->maxChars = length;
}
- stringPtr->numChars = length;
- stringPtr->hasUnicode = (length > 0);
/*
- * Ensure the string is NUL-terminated.
+ * Mark the new end of the unicode string
*/
+ stringPtr->numChars = length;
stringPtr->unicode[length] = 0;
- stringPtr->allocated = 0;
- objPtr->length = 0;
+ stringPtr->hasUnicode = 1;
+
+ /*
+ * Can only get here when objPtr->bytes == NULL. No need to invalidate
+ * the string rep.
+ */
}
}
@@ -895,9 +902,9 @@ Tcl_SetObjLength(
int
Tcl_AttemptSetObjLength(
- register Tcl_Obj *objPtr, /* Pointer to object. This object must not
+ Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
- register int length) /* Number of bytes desired for string
+ int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
@@ -905,66 +912,47 @@ Tcl_AttemptSetObjLength(
if (length < 0) {
/*
- * Setting to a negative length is nonsense. This is probably the
+ * Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
+
return 0;
}
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
}
- SetStringFromAny(NULL, objPtr);
+ if (objPtr->bytes && objPtr->length == length) {
+ return 1;
+ }
+ SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- /*
- * Check that we're not extending a pure unicode string.
- */
-
- if (length > (int) stringPtr->allocated &&
- (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
- char *newBytes;
-
+ if (objPtr->bytes != NULL) {
/*
- * Not enough space in current string. Reallocate the string space and
- * free the old string.
+ * Change length of an existing string rep.
*/
+ if (length > stringPtr->allocated) {
+ /*
+ * Need to enlarge the buffer.
+ */
- if (objPtr->bytes != tclEmptyStringRep) {
- newBytes = attemptckrealloc(objPtr->bytes,
- (unsigned)(length + 1));
- if (newBytes == NULL) {
- return 0;
+ char *newBytes;
+
+ if (objPtr->bytes == tclEmptyStringRep) {
+ newBytes = attemptckalloc(length + 1);
+ } else {
+ newBytes = attemptckrealloc(objPtr->bytes, length + 1);
}
- } else {
- newBytes = attemptckalloc((unsigned) (length + 1));
if (newBytes == NULL) {
return 0;
}
- if (objPtr->bytes != NULL && objPtr->length != 0) {
- memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length);
- Tcl_InvalidateStringRep(objPtr);
- }
+ objPtr->bytes = newBytes;
+ stringPtr->allocated = length;
}
- objPtr->bytes = newBytes;
- stringPtr->allocated = length;
-
- /*
- * Invalidate the unicode data.
- */
-
- stringPtr->hasUnicode = 0;
- }
- if (objPtr->bytes != NULL) {
objPtr->length = length;
- if (objPtr->bytes != tclEmptyStringRep) {
- /*
- * Ensure the string is NULL-terminated.
- */
-
- objPtr->bytes[length] = 0;
- }
+ objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
@@ -977,29 +965,30 @@ Tcl_AttemptSetObjLength(
* Changing length of pure unicode string.
*/
- size_t uallocated = STRING_UALLOC(length);
if (length > STRING_MAXCHARS) {
return 0;
}
-
- if (uallocated > stringPtr->uallocated) {
+ if (length > stringPtr->maxChars) {
stringPtr = stringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
SET_STRING(objPtr, stringPtr);
- stringPtr->uallocated = uallocated;
+ stringPtr->maxChars = length;
}
- stringPtr->numChars = length;
- stringPtr->hasUnicode = (length > 0);
/*
- * Ensure the string is NUL-terminated.
+ * Mark the new end of the unicode string.
*/
stringPtr->unicode[length] = 0;
- stringPtr->allocated = 0;
- objPtr->length = 0;
+ stringPtr->numChars = length;
+ stringPtr->hasUnicode = 1;
+
+ /*
+ * Can only get here when objPtr->bytes == NULL. No need to invalidate
+ * the string rep.
+ */
}
return 1;
}
@@ -1059,7 +1048,6 @@ SetUnicodeObj(
* string. */
{
String *stringPtr;
- size_t uallocated;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
@@ -1070,19 +1058,18 @@ SetUnicodeObj(
*/
stringCheckLimits(numChars);
- uallocated = STRING_UALLOC(numChars);
- stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
+ stringPtr = stringAlloc(numChars);
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
- stringPtr->numChars = numChars;
- stringPtr->uallocated = uallocated;
- stringPtr->hasUnicode = (numChars > 0);
- stringPtr->allocated = 0;
- memcpy(stringPtr->unicode, unicode, uallocated);
+ stringPtr->maxChars = numChars;
+ memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
stringPtr->unicode[numChars] = 0;
+ stringPtr->numChars = numChars;
+ stringPtr->hasUnicode = 1;
- Tcl_InvalidateStringRep(objPtr);
- objPtr->typePtr = &tclStringType;
- SET_STRING(objPtr, stringPtr);
+ TclInvalidateStringRep(objPtr);
+ stringPtr->allocated = 0;
}
/*
@@ -1105,13 +1092,13 @@ SetUnicodeObj(
void
Tcl_AppendLimitedToObj(
- register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
- register int length, /* The number of bytes available to be
+ int length, /* The number of bytes available to be
* appended from "bytes". If < 0, then all
* bytes up to a NUL byte are available. */
- register int limit, /* The maximum number of bytes to append to
+ int limit, /* The maximum number of bytes to append to
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
@@ -1124,8 +1111,6 @@ Tcl_AppendLimitedToObj(
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
- SetStringFromAny(NULL, objPtr);
-
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
}
@@ -1148,8 +1133,10 @@ Tcl_AppendLimitedToObj(
* objPtr's string rep.
*/
+ SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode != 0) {
+
+ if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
@@ -1160,10 +1147,10 @@ Tcl_AppendLimitedToObj(
}
stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode != 0) {
- AppendUtfToUnicodeRep(objPtr, ellipsis, -1);
+ if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
+ AppendUtfToUnicodeRep(objPtr, ellipsis, strlen(ellipsis));
} else {
- AppendUtfToUtfRep(objPtr, ellipsis, -1);
+ AppendUtfToUtfRep(objPtr, ellipsis, strlen(ellipsis));
}
}
@@ -1186,10 +1173,10 @@ Tcl_AppendLimitedToObj(
void
Tcl_AppendToObj(
- register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
- register int length) /* The number of bytes to append from "bytes".
+ int length) /* The number of bytes to append from "bytes".
* If < 0, then append all bytes up to NUL
* byte. */
{
@@ -1215,7 +1202,7 @@ Tcl_AppendToObj(
void
Tcl_AppendUnicodeToObj(
- register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The unicode string to append to the
* object. */
int length) /* Number of chars in "unicode". */
@@ -1239,7 +1226,11 @@ Tcl_AppendUnicodeToObj(
* objPtr's string rep.
*/
- if (stringPtr->hasUnicode != 0) {
+ if (stringPtr->hasUnicode
+#if COMPAT
+ && stringPtr->numChars > 0
+#endif
+ ) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
AppendUnicodeToUtfRep(objPtr, unicode, length);
@@ -1270,35 +1261,73 @@ Tcl_AppendObjToObj(
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
- int length, numChars, allOneByteChars;
- char *bytes;
+ int length, numChars, appendNumChars = -1;
+ const char *bytes;
+
+ /*
+ * Special case: second object is standard-empty is fast case. We know
+ * that appending nothing to anything leaves that starting anything...
+ */
+
+ if (appendObjPtr->bytes == tclEmptyStringRep) {
+ return;
+ }
+
+ /*
+ * Handle append of one bytearray object to another as a special case.
+ * Note that we only do this when the objects don't have string reps; if
+ * it did, then appending the byte arrays together could well lose
+ * information; this is a special-case optimization only.
+ */
+
+ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
+ && TclIsPureByteArray(appendObjPtr)) {
+ unsigned char *bytesSrc;
+ int lengthSrc, lengthTotal;
+
+ /*
+ * We do not assume that objPtr and appendObjPtr must be distinct!
+ * This makes this code a bit more complex than it otherwise would be,
+ * but in turn makes it much safer.
+ */
+
+ (void) Tcl_GetByteArrayFromObj(objPtr, &length);
+ (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
+ lengthTotal = length + lengthSrc;
+ if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL);
+ TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc);
+ return;
+ }
+
+ /*
+ * Must append as strings.
+ */
SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
*/
- stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode != 0) {
+ if (stringPtr->hasUnicode
+#if COMPAT
+ && stringPtr->numChars > 0
+#endif
+ ) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (appendObjPtr->typePtr == &tclStringType) {
- stringPtr = GET_STRING(appendObjPtr);
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
- /*
- * If appendObjPtr is a string obj with no valid Unicode rep,
- * then fill its unicode rep.
- */
+ Tcl_UniChar *unicode =
+ Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
- FillUnicodeRep(appendObjPtr);
- stringPtr = GET_STRING(appendObjPtr);
- }
- AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
- stringPtr->numChars);
+ AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
@@ -1314,21 +1343,20 @@ Tcl_AppendObjToObj(
bytes = TclGetStringFromObj(appendObjPtr, &length);
- allOneByteChars = 0;
numChars = stringPtr->numChars;
if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
- stringPtr = GET_STRING(appendObjPtr);
- if ((stringPtr->numChars >= 0) && (stringPtr->numChars == length)) {
- numChars += stringPtr->numChars;
- allOneByteChars = 1;
- }
+ String *appendStringPtr = GET_STRING(appendObjPtr);
+ appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
- if (allOneByteChars) {
- stringPtr = GET_STRING(objPtr);
- stringPtr->numChars = numChars;
+ if (numChars >= 0 && appendNumChars >= 0
+#if COMPAT
+ && appendNumChars == length
+#endif
+ ) {
+ stringPtr->numChars = numChars + appendNumChars;
}
}
@@ -1379,22 +1407,27 @@ AppendUnicodeToUnicodeRep(
numChars = stringPtr->numChars + appendNumChars;
stringCheckLimits(numChars);
- if (STRING_UALLOC(numChars) >= stringPtr->uallocated) {
+ if (numChars > stringPtr->maxChars) {
+ int offset = -1;
+
/*
* Protect against case where unicode points into the existing
- * stringPtr->unicode array. Force it to follow any relocations
- * due to the reallocs below.
+ * stringPtr->unicode array. Force it to follow any relocations due to
+ * the reallocs below.
*/
- int offset = -1;
- if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode
- + 1 + stringPtr->uallocated / sizeof(Tcl_UniChar)) {
+
+ if (unicode >= stringPtr->unicode
+ && unicode <= stringPtr->unicode + stringPtr->maxChars) {
offset = unicode - stringPtr->unicode;
}
-
+
GrowUnicodeBuffer(objPtr, numChars);
stringPtr = GET_STRING(objPtr);
- /* Relocate unicode if needed; see above. */
+ /*
+ * Relocate unicode if needed; see above.
+ */
+
if (offset >= 0) {
unicode = stringPtr->unicode + offset;
}
@@ -1411,7 +1444,7 @@ AppendUnicodeToUnicodeRep(
stringPtr->numChars = numChars;
stringPtr->allocated = 0;
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
}
/*
@@ -1437,20 +1470,21 @@ AppendUnicodeToUtfRep(
const Tcl_UniChar *unicode, /* String to convert to UTF. */
int numChars) /* Number of chars of "unicode" to convert. */
{
- Tcl_DString dsPtr;
- const char *bytes;
+ String *stringPtr = GET_STRING(objPtr);
- if (numChars < 0) {
- numChars = UnicodeLength(unicode);
- }
- if (numChars == 0) {
- return;
+ numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
+
+ if (stringPtr->numChars != -1) {
+ stringPtr->numChars += numChars;
}
- Tcl_DStringInit(&dsPtr);
- bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
- AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr));
- Tcl_DStringFree(&dsPtr);
+#if COMPAT
+ /*
+ * Invalidate the unicode rep.
+ */
+
+ stringPtr->hasUnicode = 0;
+#endif
}
/*
@@ -1460,7 +1494,7 @@ AppendUnicodeToUtfRep(
*
* This function converts the contents of "bytes" to Unicode and appends
* the Unicode to the Unicode rep of "objPtr". objPtr must already have a
- * valid Unicode rep.
+ * valid Unicode rep. numBytes must be non-negative.
*
* Results:
* None.
@@ -1477,22 +1511,16 @@ AppendUtfToUnicodeRep(
const char *bytes, /* String to convert to Unicode. */
int numBytes) /* Number of bytes of "bytes" to convert. */
{
- Tcl_DString dsPtr;
- int numChars;
- Tcl_UniChar *unicode;
+ String *stringPtr;
- if (numBytes < 0) {
- numBytes = (bytes ? strlen(bytes) : 0);
- }
if (numBytes == 0) {
return;
}
- Tcl_DStringInit(&dsPtr);
- numChars = Tcl_NumUtfChars(bytes, numBytes);
- unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
- AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
- Tcl_DStringFree(&dsPtr);
+ ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1);
+ TclInvalidateStringRep(objPtr);
+ stringPtr = GET_STRING(objPtr);
+ stringPtr->allocated = 0;
}
/*
@@ -1502,6 +1530,7 @@ AppendUtfToUnicodeRep(
*
* This function appends "numBytes" bytes of "bytes" to the UTF string
* rep of "objPtr". objPtr must already have a valid String rep.
+ * numBytes must be non-negative.
*
* Results:
* None.
@@ -1521,9 +1550,6 @@ AppendUtfToUtfRep(
String *stringPtr;
int newLength, oldLength;
- if (numBytes < 0) {
- numBytes = (bytes ? strlen(bytes) : 0);
- }
if (numBytes == 0) {
return;
}
@@ -1533,6 +1559,9 @@ AppendUtfToUtfRep(
* trailing null.
*/
+ if (objPtr->bytes == NULL) {
+ objPtr->length = 0;
+ }
oldLength = objPtr->length;
newLength = numBytes + oldLength;
if (newLength < 0) {
@@ -1540,40 +1569,32 @@ AppendUtfToUtfRep(
}
stringPtr = GET_STRING(objPtr);
- if (newLength > (int) stringPtr->allocated) {
+ if (newLength > stringPtr->allocated) {
+ int offset = -1;
+
/*
* Protect against case where unicode points into the existing
- * stringPtr->unicode array. Force it to follow any relocations
- * due to the reallocs below.
+ * stringPtr->unicode array. Force it to follow any relocations due to
+ * the reallocs below.
*/
- int offset = -1;
+
if (bytes >= objPtr->bytes
&& bytes <= objPtr->bytes + objPtr->length) {
offset = bytes - objPtr->bytes;
}
/*
- * There isn't currently enough space in the string representation so
- * allocate additional space. First, try to double the length
- * required. If that fails, try a more modest allocation. See the "TCL
- * STRING GROWTH ALGORITHM" comment at the top of this file for an
- * explanation of this growth algorithm.
+ * TODO: consider passing flag=1: no overalloc on first append. This
+ * would make test stringObj-8.1 fail.
*/
- if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
- /*
- * Take care computing the amount of modest growth to avoid
- * overflow into invalid argument values for Tcl_SetObjLength.
- */
- unsigned int limit = INT_MAX - newLength;
- unsigned int extra = numBytes + TCL_GROWTH_MIN_ALLOC;
- int growth = (int) ((extra > limit) ? limit : extra);
-
- Tcl_SetObjLength(objPtr, newLength + growth);
- }
+ GrowStringBuffer(objPtr, newLength, 0);
- /* Relocate bytes if needed; see above. */
- if (offset >=0) {
+ /*
+ * Relocate bytes if needed; see above.
+ */
+
+ if (offset >= 0) {
bytes = objPtr->bytes + offset;
}
}
@@ -1585,7 +1606,7 @@ AppendUtfToUtfRep(
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
- memcpy(objPtr->bytes + oldLength, bytes, (size_t) numBytes);
+ memcpy(objPtr->bytes + oldLength, bytes, numBytes);
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
}
@@ -1613,130 +1634,18 @@ Tcl_AppendStringsToObjVA(
Tcl_Obj *objPtr, /* Points to the object to append to. */
va_list argList) /* Variable argument list. */
{
-#define STATIC_LIST_SIZE 16
- String *stringPtr;
- int newLength, oldLength, attemptLength;
- register char *string, *dst;
- char *static_list[STATIC_LIST_SIZE];
- char **args = static_list;
- int nargs_space = STATIC_LIST_SIZE;
- int nargs, i;
-
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj");
}
- SetStringFromAny(NULL, objPtr);
-
- /*
- * Force the existence of a string rep. so we avoid crashes operating
- * on a pure unicode value. [Bug 2597185]
- */
-
- (void) Tcl_GetStringFromObj(objPtr, &oldLength);
-
- /*
- * Figure out how much space is needed for all the strings, and expand the
- * string representation if it isn't big enough. If no bytes would be
- * appended, just return. Note that on some platforms (notably OS/390) the
- * argList is an array so we need to use memcpy.
- */
-
- nargs = 0;
- newLength = 0;
while (1) {
- string = va_arg(argList, char *);
- if (string == NULL) {
- break;
- }
- if (nargs >= nargs_space) {
- /*
- * Expand the args buffer.
- */
-
- nargs_space += STATIC_LIST_SIZE;
- if (args == static_list) {
- args = (void *) ckalloc(nargs_space * sizeof(char *));
- for (i = 0; i < nargs; ++i) {
- args[i] = static_list[i];
- }
- } else {
- args = (void *) ckrealloc((void *) args,
- nargs_space * sizeof(char *));
- }
- }
- newLength += strlen(string);
- args[nargs++] = string;
- }
- if (newLength == 0) {
- goto done;
- }
-
- stringPtr = GET_STRING(objPtr);
- if (oldLength + newLength > (int) stringPtr->allocated) {
- /*
- * There isn't currently enough space in the string representation, so
- * allocate additional space. If the current string representation
- * isn't empty (i.e. it looks like we're doing a series of appends)
- * then try to allocate extra space to accomodate future growth: first
- * try to double the required memory; if that fails, try a more modest
- * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the
- * top of this file for an explanation of this growth algorithm.
- * Otherwise, if the current string representation is empty, exactly
- * enough memory is allocated.
- */
-
- if (oldLength == 0) {
- Tcl_SetObjLength(objPtr, newLength);
- } else {
- attemptLength = 2 * (oldLength + newLength);
- if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
- attemptLength = oldLength + (2 * newLength) +
- TCL_GROWTH_MIN_ALLOC;
- Tcl_SetObjLength(objPtr, attemptLength);
- }
- }
- }
-
- /*
- * Make a second pass through the arguments, appending all the strings to
- * the object.
- */
+ const char *bytes = va_arg(argList, char *);
- dst = objPtr->bytes + oldLength;
- for (i = 0; i < nargs; ++i) {
- string = args[i];
- if (string == NULL) {
+ if (bytes == NULL) {
break;
}
- while (*string != 0) {
- *dst = *string;
- dst++;
- string++;
- }
+ Tcl_AppendToObj(objPtr, bytes, -1);
}
-
- /*
- * Add a null byte to terminate the string. However, be careful: it's
- * possible that the object is totally empty (if it was empty originally
- * and there was nothing to append). In this case dst is NULL; just leave
- * everything alone.
- */
-
- if (dst != NULL) {
- *dst = 0;
- }
- objPtr->length = oldLength + newLength;
-
- done:
- /*
- * If we had to allocate a buffer from the heap, free it now.
- */
-
- if (args != static_list) {
- ckfree((void *) args);
- }
-#undef STATIC_LIST_SIZE
}
/*
@@ -1797,12 +1706,12 @@ Tcl_AppendFormatToObj(
int objc,
Tcl_Obj *const objv[])
{
- const char *span = format, *msg;
+ const char *span = format, *msg, *errCode;
int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
int originalLength, limit;
static const char *mixedXPG =
"cannot mix \"%\" and \"%n$\" conversion specifiers";
- static const char *badIndex[2] = {
+ static const char *const badIndex[2] = {
"not enough arguments for all format specifiers",
"\"%n$\" argument index out of range"
};
@@ -1835,6 +1744,7 @@ Tcl_AppendFormatToObj(
if (numBytes) {
if (numBytes > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(appendObj, span, numBytes);
@@ -1863,6 +1773,7 @@ Tcl_AppendFormatToObj(
newXpg = 0;
if (isdigit(UCHAR(ch))) {
int position = strtoul(format, &end, 10);
+
if (*end == '$') {
newXpg = 1;
objIndex = position - 1;
@@ -1873,18 +1784,21 @@ Tcl_AppendFormatToObj(
if (newXpg) {
if (gotSequential) {
msg = mixedXPG;
+ errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotXpg = 1;
} else {
if (gotXpg) {
msg = mixedXPG;
+ errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotSequential = 1;
}
if ((objIndex < 0) || (objIndex >= objc)) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
@@ -1932,6 +1846,7 @@ Tcl_AppendFormatToObj(
} else if (ch == '*') {
if (objIndex >= objc - 1) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
@@ -1947,6 +1862,7 @@ Tcl_AppendFormatToObj(
}
if (width > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
@@ -1967,6 +1883,7 @@ Tcl_AppendFormatToObj(
} else if (ch == '*') {
if (objIndex >= objc - 1) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
if (TclGetIntFromObj(interp, objv[objIndex], &precision)
@@ -2002,8 +1919,8 @@ Tcl_AppendFormatToObj(
useBig = 1;
format += step;
step = Tcl_UtfToUniChar(format, &ch);
- } else {
#ifndef TCL_WIDE_INT_IS_LONG
+ } else {
useWide = 1;
#endif
}
@@ -2024,6 +1941,7 @@ Tcl_AppendFormatToObj(
switch (ch) {
case '\0':
msg = "format string ended in middle of field specifier";
+ errCode = "INCOMPLETE";
goto errorMsg;
case 's':
if (gotPrecision) {
@@ -2053,13 +1971,15 @@ Tcl_AppendFormatToObj(
case 'u':
if (useBig) {
msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
goto errorMsg;
}
case 'd':
case 'o':
case 'x':
- case 'X': {
- short int s = 0; /* Silence compiler warning; only defined and
+ case 'X':
+ case 'b': {
+ short s = 0; /* Silence compiler warning; only defined and
* used when useShort is true. */
long l;
Tcl_WideInt w;
@@ -2084,7 +2004,7 @@ Tcl_AppendFormatToObj(
Tcl_GetWideIntFromObj(NULL, objPtr, &w);
Tcl_DecrRefCount(objPtr);
}
- isNegative = (w < (Tcl_WideInt)0);
+ isNegative = (w < (Tcl_WideInt) 0);
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
@@ -2101,16 +2021,16 @@ Tcl_AppendFormatToObj(
l = Tcl_WideAsLong(w);
}
if (useShort) {
- s = (short int) l;
- isNegative = (s < (short int)0);
+ s = (short) l;
+ isNegative = (s < (short) 0);
} else {
- isNegative = (l < (long)0);
+ isNegative = (l < (long) 0);
}
} else if (useShort) {
- s = (short int) l;
- isNegative = (s < (short int)0);
+ s = (short) l;
+ isNegative = (s < (short) 0);
} else {
- isNegative = (l < (long)0);
+ isNegative = (l < (long) 0);
}
segment = Tcl_NewObj();
@@ -2118,8 +2038,9 @@ Tcl_AppendFormatToObj(
segmentLimit = INT_MAX;
Tcl_IncrRefCount(segment);
- if ((isNegative || gotPlus || gotSpace) && (useBig || (ch == 'd'))) {
- Tcl_AppendToObj(segment, (isNegative ? "-" : gotPlus ? "+" : " "), 1);
+ if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
+ Tcl_AppendToObj(segment,
+ (isNegative ? "-" : gotPlus ? "+" : " "), 1);
segmentLimit -= 1;
}
@@ -2135,6 +2056,10 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
+ case 'b':
+ Tcl_AppendToObj(segment, "0b", 2);
+ segmentLimit -= 2;
+ break;
}
}
@@ -2145,7 +2070,7 @@ Tcl_AppendFormatToObj(
const char *bytes;
if (useShort) {
- pure = Tcl_NewIntObj((int)(s));
+ pure = Tcl_NewIntObj((int) s);
} else if (useWide) {
pure = Tcl_NewWideIntObj(w);
} else if (useBig) {
@@ -2174,7 +2099,7 @@ Tcl_AppendFormatToObj(
if (gotPrecision) {
if (length < precision) {
- segmentLimit -= (precision - length);
+ segmentLimit -= precision - length;
}
while (length < precision) {
Tcl_AppendToObj(segment, "0", 1);
@@ -2185,7 +2110,7 @@ Tcl_AppendFormatToObj(
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < width) {
- segmentLimit -= (width - length);
+ segmentLimit -= width - length;
}
while (length < width) {
Tcl_AppendToObj(segment, "0", 1);
@@ -2194,6 +2119,7 @@ Tcl_AppendFormatToObj(
}
if (toAppend > segmentLimit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(segment, bytes, toAppend);
@@ -2204,23 +2130,25 @@ Tcl_AppendFormatToObj(
case 'u':
case 'o':
case 'x':
- case 'X': {
- Tcl_WideUInt bits = (Tcl_WideUInt)0;
- Tcl_WideInt numDigits = (Tcl_WideInt)0;
- int length, numBits = 4, base = 16;
- int index = 0, shift = 0;
+ case 'X':
+ case 'b': {
+ Tcl_WideUInt bits = (Tcl_WideUInt) 0;
+ Tcl_WideInt numDigits = (Tcl_WideInt) 0;
+ int length, numBits = 4, base = 16, index = 0, shift = 0;
Tcl_Obj *pure;
char *bytes;
if (ch == 'u') {
base = 10;
- }
- if (ch == 'o') {
+ } else if (ch == 'o') {
base = 8;
numBits = 3;
+ } else if (ch == 'b') {
+ base = 2;
+ numBits = 1;
}
if (useShort) {
- unsigned short int us = (unsigned short int) s;
+ unsigned short us = (unsigned short) s;
bits = (Tcl_WideUInt) us;
while (us) {
@@ -2240,17 +2168,18 @@ Tcl_AppendFormatToObj(
mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
numDigits = 1 +
- (((Tcl_WideInt)big.used * DIGIT_BIT) / numBits);
+ (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
while ((mask & big.dp[big.used-1]) == 0) {
numDigits--;
mask >>= numBits;
}
if (numDigits > INT_MAX) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
} else if (!useBig) {
- unsigned long int ul = (unsigned long int) l;
+ unsigned long ul = (unsigned long) l;
bits = (Tcl_WideUInt) ul;
while (ul) {
@@ -2267,16 +2196,16 @@ Tcl_AppendFormatToObj(
numDigits = 1;
}
pure = Tcl_NewObj();
- Tcl_SetObjLength(pure, (int)numDigits);
+ Tcl_SetObjLength(pure, (int) numDigits);
bytes = TclGetString(pure);
- toAppend = length = (int)numDigits;
+ toAppend = length = (int) numDigits;
while (numDigits--) {
int digitOffset;
if (useBig && big.used) {
if (index < big.used && (size_t) shift <
CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) {
- bits |= (((Tcl_WideUInt)big.dp[index++]) <<shift);
+ bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
shift += DIGIT_BIT;
}
shift -= numBits;
@@ -2294,7 +2223,7 @@ Tcl_AppendFormatToObj(
}
if (gotPrecision) {
if (length < precision) {
- segmentLimit -= (precision - length);
+ segmentLimit -= precision - length;
}
while (length < precision) {
Tcl_AppendToObj(segment, "0", 1);
@@ -2305,7 +2234,7 @@ Tcl_AppendFormatToObj(
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < width) {
- segmentLimit -= (width - length);
+ segmentLimit -= width - length;
}
while (length < width) {
Tcl_AppendToObj(segment, "0", 1);
@@ -2314,6 +2243,7 @@ Tcl_AppendFormatToObj(
}
if (toAppend > segmentLimit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendObjToObj(segment, pure);
@@ -2360,13 +2290,14 @@ Tcl_AppendFormatToObj(
p += sprintf(p, "%d", width);
if (width > length) {
length = width;
- }
+ }
}
if (gotPrecision) {
*p++ = '.';
p += sprintf(p, "%d", precision);
if (precision > INT_MAX - length) {
- msg=overflow;
+ msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
length += precision;
@@ -2383,11 +2314,13 @@ Tcl_AppendFormatToObj(
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
break;
@@ -2396,6 +2329,7 @@ Tcl_AppendFormatToObj(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
}
goto error;
}
@@ -2408,18 +2342,16 @@ Tcl_AppendFormatToObj(
}
}
- if (width > 0) {
- if (numChars < 0) {
- numChars = Tcl_GetCharLength(segment);
+ if (width>0 && numChars<0) {
+ numChars = Tcl_GetCharLength(segment);
+ }
+ if (!gotMinus && width>0) {
+ if (numChars < width) {
+ limit -= width - numChars;
}
- if (!gotMinus) {
- if (numChars < width) {
- limit -= (width - numChars);
- }
- while (numChars < width) {
- Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
- numChars++;
- }
+ while (numChars < width) {
+ Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
+ numChars++;
}
}
@@ -2429,6 +2361,7 @@ Tcl_AppendFormatToObj(
Tcl_DecrRefCount(segment);
}
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendObjToObj(appendObj, segment);
@@ -2438,7 +2371,7 @@ Tcl_AppendFormatToObj(
}
if (width > 0) {
if (numChars < width) {
- limit -= (width - numChars);
+ limit -= width-numChars;
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
@@ -2451,6 +2384,7 @@ Tcl_AppendFormatToObj(
if (numBytes) {
if (numBytes > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(appendObj, span, numBytes);
@@ -2463,6 +2397,7 @@ Tcl_AppendFormatToObj(
errorMsg:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
}
error:
Tcl_SetObjLength(appendObj, originalLength);
@@ -2478,7 +2413,7 @@ Tcl_AppendFormatToObj(
* A refcount zero Tcl_Obj.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
@@ -2492,6 +2427,7 @@ Tcl_Format(
{
int result;
Tcl_Obj *objPtr = Tcl_NewObj();
+
result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);
if (result != TCL_OK) {
Tcl_DecrRefCount(objPtr);
@@ -2521,7 +2457,6 @@ AppendPrintfToObjVA(
int code, objc;
Tcl_Obj **objv, *list = Tcl_NewObj();
const char *p;
- char *end;
p = format;
Tcl_IncrRefCount(list);
@@ -2538,7 +2473,6 @@ AppendPrintfToObjVA(
}
do {
switch (*p) {
-
case '\0':
seekingConversion = 0;
break;
@@ -2591,11 +2525,11 @@ AppendPrintfToObjVA(
case -1:
case 0:
Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
- (long int)va_arg(argList, int)));
+ (long) va_arg(argList, int)));
break;
case 1:
Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
- va_arg(argList, long int)));
+ va_arg(argList, long)));
break;
}
break;
@@ -2609,15 +2543,18 @@ AppendPrintfToObjVA(
seekingConversion = 0;
break;
case '*':
- lastNum = (int)va_arg(argList, int);
+ lastNum = (int) va_arg(argList, int);
Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
+ case '5': case '6': case '7': case '8': case '9': {
+ char *end;
+
lastNum = (int) strtoul(p, &end, 10);
p = end;
break;
+ }
case '.':
gotPrecision = 1;
p++;
@@ -2653,7 +2590,7 @@ AppendPrintfToObjVA(
* A standard Tcl result.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
@@ -2680,7 +2617,7 @@ Tcl_AppendPrintfToObj(
* A refcount zero Tcl_Obj.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
@@ -2708,8 +2645,8 @@ Tcl_ObjPrintf(
*
* Results:
* An unshared Tcl value which is the [string reverse] of the argument
- * supplied. When sharing rules permit, the returned value might be
- * the argument with modifications done in place.
+ * supplied. When sharing rules permit, the returned value might be the
+ * argument with modifications done in place.
*
* Side effects:
* May allocate a new Tcl_Obj.
@@ -2722,63 +2659,94 @@ TclStringObjReverse(
Tcl_Obj *objPtr)
{
String *stringPtr;
- int numChars = Tcl_GetCharLength(objPtr);
- int i = 0, lastCharIdx = numChars - 1;
- char *bytes;
-
- if (numChars <= 1) {
- return objPtr;
- }
+ char *src = NULL, *dest = NULL;
+ Tcl_UniChar *usrc = NULL, *udest = NULL;
+ Tcl_Obj *resultPtr = NULL;
+ SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode) {
- Tcl_UniChar *source = stringPtr->unicode;
- if (Tcl_IsShared(objPtr)) {
- Tcl_UniChar *dest, ch = 0;
+ if (stringPtr->hasUnicode == 0) {
+ if (stringPtr->numChars == -1) {
+ TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ }
+ if (stringPtr->numChars <= 1) {
+ return objPtr;
+ }
+ if (stringPtr->numChars == objPtr->length) {
+ /*
+ * All one-byte chars. Reverse in objPtr->bytes.
+ */
+
+ if (Tcl_IsShared(objPtr)) {
+ resultPtr = Tcl_NewObj();
+ Tcl_SetObjLength(resultPtr, objPtr->length);
+ dest = TclGetString(resultPtr);
+ src = objPtr->bytes + objPtr->length - 1;
+ while (src >= objPtr->bytes) {
+ *dest++ = *src--;
+ }
+ return resultPtr;
+ }
/*
- * Create a non-empty, pure unicode value, so we can coax
- * Tcl_SetObjLength into growing the unicode rep buffer.
+ * Unshared. Reverse objPtr->bytes in place.
*/
- Tcl_Obj *resultPtr = Tcl_NewUnicodeObj(&ch, 1);
- Tcl_SetObjLength(resultPtr, numChars);
- dest = Tcl_GetUnicode(resultPtr);
+ dest = objPtr->bytes;
+ src = dest + objPtr->length - 1;
+ while (dest < src) {
+ char tmp = *src;
- while (i < numChars) {
- dest[i++] = source[lastCharIdx--];
+ *src-- = *dest;
+ *dest++ = tmp;
}
- return resultPtr;
- }
-
- while (i < lastCharIdx) {
- Tcl_UniChar tmp = source[lastCharIdx];
- source[lastCharIdx--] = source[i];
- source[i++] = tmp;
+ return objPtr;
}
- Tcl_InvalidateStringRep(objPtr);
- stringPtr->allocated = 0;
+ FillUnicodeRep(objPtr);
+ stringPtr = GET_STRING(objPtr);
+ }
+ if (stringPtr->numChars <= 1) {
return objPtr;
}
- bytes = TclGetString(objPtr);
+ /*
+ * Reverse the Unicode rep.
+ */
+
if (Tcl_IsShared(objPtr)) {
- char *dest;
- Tcl_Obj *resultPtr = Tcl_NewObj();
- Tcl_SetObjLength(resultPtr, numChars);
- dest = TclGetString(resultPtr);
- while (i < numChars) {
- dest[i++] = bytes[lastCharIdx--];
+ Tcl_UniChar ch = 0;
+
+ /*
+ * Create a non-empty, pure unicode value, so we can coax
+ * Tcl_SetObjLength into growing the unicode rep buffer.
+ */
+
+ resultPtr = Tcl_NewUnicodeObj(&ch, 1);
+ Tcl_SetObjLength(resultPtr, stringPtr->numChars);
+ udest = Tcl_GetUnicode(resultPtr);
+ usrc = stringPtr->unicode + stringPtr->numChars - 1;
+ while (usrc >= stringPtr->unicode) {
+ *udest++ = *usrc--;
}
return resultPtr;
}
- while (i < lastCharIdx) {
- char tmp = bytes[lastCharIdx];
- bytes[lastCharIdx--] = bytes[i];
- bytes[i++] = tmp;
+ /*
+ * Unshared. Reverse objPtr->bytes in place.
+ */
+
+ udest = stringPtr->unicode;
+ usrc = udest + stringPtr->numChars - 1;
+ while (udest < usrc) {
+ Tcl_UniChar tmp = *usrc;
+
+ *usrc-- = *udest;
+ *udest++ = tmp;
}
+
+ TclInvalidateStringRep(objPtr);
+ stringPtr->allocated = 0;
return objPtr;
}
@@ -2804,35 +2772,43 @@ FillUnicodeRep(
Tcl_Obj *objPtr) /* The object in which to fill the unicode
* rep. */
{
- String *stringPtr;
- size_t uallocated;
- char *srcEnd, *src = objPtr->bytes;
+ String *stringPtr = GET_STRING(objPtr);
+
+ ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length,
+ stringPtr->numChars);
+}
+
+static void
+ExtendUnicodeRepWithString(
+ Tcl_Obj *objPtr,
+ const char *bytes,
+ int numBytes,
+ int numAppendChars)
+{
+ String *stringPtr = GET_STRING(objPtr);
+ int needed, numOrigChars = 0;
Tcl_UniChar *dst;
- stringPtr = GET_STRING(objPtr);
- if (stringPtr->numChars == -1) {
- stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
+ if (stringPtr->hasUnicode) {
+ numOrigChars = stringPtr->numChars;
}
- stringPtr->hasUnicode = (stringPtr->numChars > 0);
-
- stringCheckLimits(stringPtr->numChars);
- uallocated = STRING_UALLOC(stringPtr->numChars);
- if (uallocated > stringPtr->uallocated) {
- GrowUnicodeBuffer(objPtr, stringPtr->numChars);
+ if (numAppendChars == -1) {
+ TclNumUtfChars(numAppendChars, bytes, numBytes);
+ }
+ needed = numOrigChars + numAppendChars;
+ stringCheckLimits(needed);
+
+ if (needed > stringPtr->maxChars) {
+ GrowUnicodeBuffer(objPtr, needed);
stringPtr = GET_STRING(objPtr);
}
- /*
- * Convert src to Unicode and store the coverted data in "unicode".
- */
-
- srcEnd = src + objPtr->length;
- for (dst = stringPtr->unicode; src < srcEnd; dst++) {
- src += TclUtfToUniChar(src, dst);
+ stringPtr->hasUnicode = 1;
+ stringPtr->numChars = needed;
+ for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
+ bytes += TclUtfToUniChar(bytes, dst);
}
*dst = 0;
-
- SET_STRING(objPtr, stringPtr);
}
/*
@@ -2855,36 +2831,49 @@ FillUnicodeRep(
static void
DupStringInternalRep(
- register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
* an internal rep of type "String". */
- register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
- /*
- * If the src obj is a string of 1-byte Utf chars, then copy the string
- * rep of the source object and create an "empty" Unicode internal rep for
- * the new object. Otherwise, copy Unicode internal rep, and invalidate
- * the string rep of the new object.
- */
+#if COMPAT==0
+ if (srcStringPtr->numChars == -1) {
+ /*
+ * The String struct in the source value holds zero useful data. Don't
+ * bother copying it. Don't even bother allocating space in which to
+ * copy it. Just let the copy be untyped.
+ */
- if (srcStringPtr->hasUnicode == 0) {
- copyStringPtr = (String *) ckalloc(sizeof(String));
- copyStringPtr->uallocated = 0;
- } else {
- copyStringPtr = (String *) ckalloc(
- STRING_SIZE(srcStringPtr->uallocated));
- copyStringPtr->uallocated = srcStringPtr->uallocated;
+ return;
+ }
+
+ if (srcStringPtr->hasUnicode) {
+ int copyMaxChars;
+ if (srcStringPtr->maxChars / 2 >= srcStringPtr->numChars) {
+ copyMaxChars = 2 * srcStringPtr->numChars;
+ } else {
+ copyMaxChars = srcStringPtr->maxChars;
+ }
+ copyStringPtr = stringAttemptAlloc(copyMaxChars);
+ if (copyStringPtr == NULL) {
+ copyMaxChars = srcStringPtr->numChars;
+ copyStringPtr = stringAlloc(copyMaxChars);
+ }
+ copyStringPtr->maxChars = copyMaxChars;
memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
- (size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar));
+ srcStringPtr->numChars * sizeof(Tcl_UniChar));
copyStringPtr->unicode[srcStringPtr->numChars] = 0;
+ } else {
+ copyStringPtr = stringAlloc(0);
+ copyStringPtr->maxChars = 0;
+ copyStringPtr->unicode[0] = 0;
}
- copyStringPtr->numChars = srcStringPtr->numChars;
copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
- copyStringPtr->allocated = srcStringPtr->allocated;
+ copyStringPtr->numChars = srcStringPtr->numChars;
/*
* Tricky point: the string value was copied by generic object management
@@ -2892,7 +2881,42 @@ DupStringInternalRep(
* source object.
*/
- copyStringPtr->allocated = copyPtr->length;
+ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0;
+#else /* COMPAT!=0 */
+ /*
+ * If the src obj is a string of 1-byte Utf chars, then copy the string
+ * rep of the source object and create an "empty" Unicode internal rep for
+ * the new object. Otherwise, copy Unicode internal rep, and invalidate
+ * the string rep of the new object.
+ */
+
+ if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) {
+ /*
+ * Copy the full allocation for the Unicode buffer.
+ */
+
+ copyStringPtr = stringAlloc(srcStringPtr->maxChars);
+ copyStringPtr->maxChars = srcStringPtr->maxChars;
+ memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
+ srcStringPtr->numChars * sizeof(Tcl_UniChar));
+ copyStringPtr->unicode[srcStringPtr->numChars] = 0;
+ copyStringPtr->allocated = 0;
+ } else {
+ copyStringPtr = stringAlloc(0);
+ copyStringPtr->unicode[0] = 0;
+ copyStringPtr->maxChars = 0;
+
+ /*
+ * Tricky point: the string value was copied by generic object
+ * management code, so it doesn't contain any extra bytes that might
+ * exist in the source object.
+ */
+
+ copyStringPtr->allocated = copyPtr->length;
+ }
+ copyStringPtr->numChars = srcStringPtr->numChars;
+ copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
+#endif /* COMPAT==0 */
SET_STRING(copyPtr, copyStringPtr);
copyPtr->typePtr = &tclStringType;
@@ -2918,43 +2942,29 @@ DupStringInternalRep(
static int
SetStringFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
+ Tcl_Obj *objPtr) /* The object to convert. */
{
- /*
- * The Unicode object is optimized for the case where each UTF char in a
- * string is only one byte. In this case, we store the value of numChars,
- * but we don't copy the bytes to the unicodeObj->unicode.
- */
-
if (objPtr->typePtr != &tclStringType) {
- String *stringPtr;
+ String *stringPtr = stringAlloc(0);
- if (objPtr->typePtr != NULL) {
- if (objPtr->bytes == NULL) {
- objPtr->typePtr->updateStringProc(objPtr);
- }
- TclFreeIntRep(objPtr);
- }
- objPtr->typePtr = &tclStringType;
+ /*
+ * Convert whatever we have into an untyped value. Just A String.
+ */
+
+ (void) TclGetString(objPtr);
+ TclFreeIntRep(objPtr);
/*
- * Allocate enough space for the basic String structure.
+ * Create a basic String intrep that just points to the UTF-8 string
+ * already in place at objPtr->bytes.
*/
- stringPtr = (String *) ckalloc(sizeof(String));
stringPtr->numChars = -1;
- stringPtr->uallocated = 0;
+ stringPtr->allocated = objPtr->length;
+ stringPtr->maxChars = 0;
stringPtr->hasUnicode = 0;
-
- if (objPtr->bytes != NULL) {
- stringPtr->allocated = objPtr->length;
- if (objPtr->bytes != tclEmptyStringRep) {
- objPtr->bytes[objPtr->length] = 0;
- }
- } else {
- objPtr->length = 0;
- }
SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
}
return TCL_OK;
}
@@ -2981,57 +2991,75 @@ static void
UpdateStringOfString(
Tcl_Obj *objPtr) /* Object with string rep to update. */
{
- int i, size;
- Tcl_UniChar *unicode;
- char dummy[TCL_UTF_MAX];
- char *dst;
- String *stringPtr;
+ String *stringPtr = GET_STRING(objPtr);
- stringPtr = GET_STRING(objPtr);
- if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {
- if (stringPtr->numChars <= 0) {
- /*
- * If there is no Unicode rep, or the string has 0 chars, then set
- * the string rep to an empty string.
- */
+ if (stringPtr->numChars == 0) {
+ TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ } else {
+ (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
+ stringPtr->numChars);
+ }
+}
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
- return;
- }
+static int
+ExtendStringRepWithUnicode(
+ Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode,
+ int numChars)
+{
+ /*
+ * Pre-condition: this is the "string" Tcl_ObjType.
+ */
- unicode = stringPtr->unicode;
+ int i, origLength, size = 0;
+ char *dst, buf[TCL_UTF_MAX];
+ String *stringPtr = GET_STRING(objPtr);
- /*
- * Translate the Unicode string to UTF. "size" will hold the amount of
- * space the UTF string needs.
- */
+ if (numChars < 0) {
+ numChars = UnicodeLength(unicode);
+ }
- if (stringPtr->numChars <= INT_MAX/TCL_UTF_MAX
- && stringPtr->allocated >= stringPtr->numChars * (size_t)TCL_UTF_MAX) {
- goto copyBytes;
- }
+ if (numChars == 0) {
+ return 0;
+ }
- size = 0;
- for (i = 0; i < stringPtr->numChars && size >= 0; i++) {
- size += Tcl_UniCharToUtf((int) unicode[i], dummy);
- }
- if (size < 0) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
+ if (objPtr->bytes == NULL) {
+ objPtr->length = 0;
+ }
+ size = origLength = objPtr->length;
+
+ /*
+ * Quick cheap check in case we have more than enough room.
+ */
- objPtr->bytes = (char *) ckalloc((unsigned) (size + 1));
- objPtr->length = size;
- stringPtr->allocated = size;
+ if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
+ && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
+ goto copyBytes;
+ }
- copyBytes:
- dst = objPtr->bytes;
- for (i = 0; i < stringPtr->numChars; i++) {
- dst += Tcl_UniCharToUtf(unicode[i], dst);
- }
- *dst = '\0';
+ for (i = 0; i < numChars && size >= 0; i++) {
+ size += Tcl_UniCharToUtf((int) unicode[i], buf);
+ }
+ if (size < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- return;
+
+ /*
+ * Grow space if needed.
+ */
+
+ if (size > stringPtr->allocated) {
+ GrowStringBuffer(objPtr, size, 1);
+ }
+
+ copyBytes:
+ dst = objPtr->bytes + origLength;
+ for (i = 0; i < numChars; i++) {
+ dst += Tcl_UniCharToUtf((int) unicode[i], dst);
+ }
+ *dst = '\0';
+ objPtr->length = dst - objPtr->bytes;
+ return numChars;
}
/*
@@ -3055,7 +3083,7 @@ static void
FreeStringInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree((char *) GET_STRING(objPtr));
+ ckfree(GET_STRING(objPtr));
objPtr->typePtr = NULL;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index bc29ee6..054ece5 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclStubInit.c --
*
* This file contains the initializers for the Tcl stub vectors.
@@ -12,6 +12,12 @@
#include "tclInt.h"
#include "tommath.h"
+#ifdef __GNUC__
+#pragma GCC dependency "tcl.decls"
+#pragma GCC dependency "tclInt.decls"
+#pragma GCC dependency "tclTomMath.decls"
+#endif
+
/*
* Remove macros that will interfere with the definitions below.
*/
@@ -31,160 +37,136 @@
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
+#undef Tcl_Panic
+#undef Tcl_FindExecutable
#define TclpLocaltime_unix TclpLocaltime
#define TclpGmtime_unix TclpGmtime
/*
- * Keep a record of the original Notifier procedures, created in the
- * same compilation unit as the stub tables so we can later do reliable,
- * portable comparisons to see whether a Tcl_SetNotifier() call swapped
- * new routines into the stub table.
- */
-
-Tcl_NotifierProcs tclOriginalNotifier = {
- Tcl_SetTimer,
- Tcl_WaitForEvent,
-#if !defined(__WIN32__) /* UNIX */
- Tcl_CreateFileHandler,
- Tcl_DeleteFileHandler,
-#else
- NULL,
- NULL,
-#endif
- NULL,
- NULL,
- NULL,
- NULL
-};
-
-MODULE_SCOPE TclIntStubs tclIntStubs;
-MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs;
-MODULE_SCOPE TclPlatStubs tclPlatStubs;
-MODULE_SCOPE TclStubs tclStubs;
-MODULE_SCOPE TclTomMathStubs tclTomMathStubs;
-
-/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
+MODULE_SCOPE const TclStubs tclStubs;
+MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
+
/* !BEGIN!: Do not edit below this line. */
-TclIntStubs tclIntStubs = {
+static const TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
- NULL,
- NULL, /* 0 */
- NULL, /* 1 */
- NULL, /* 2 */
+ 0,
+ 0, /* 0 */
+ 0, /* 1 */
+ 0, /* 2 */
TclAllocateFreeObjects, /* 3 */
- NULL, /* 4 */
+ 0, /* 4 */
TclCleanupChildren, /* 5 */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
- TclCopyChannel, /* 8 */
+ TclCopyChannelOld, /* 8 */
TclCreatePipeline, /* 9 */
TclCreateProc, /* 10 */
TclDeleteCompiledLocalVars, /* 11 */
TclDeleteVars, /* 12 */
- NULL, /* 13 */
+ 0, /* 13 */
TclDumpMemoryInfo, /* 14 */
- NULL, /* 15 */
+ 0, /* 15 */
TclExprFloatError, /* 16 */
- NULL, /* 17 */
- NULL, /* 18 */
- NULL, /* 19 */
- NULL, /* 20 */
- NULL, /* 21 */
+ 0, /* 17 */
+ 0, /* 18 */
+ 0, /* 19 */
+ 0, /* 20 */
+ 0, /* 21 */
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
TclFreePackageInfo, /* 25 */
- NULL, /* 26 */
- NULL, /* 27 */
+ 0, /* 26 */
+ 0, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
- NULL, /* 29 */
- NULL, /* 30 */
+ 0, /* 29 */
+ 0, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
- NULL, /* 33 */
+ 0, /* 33 */
TclGetIntForIndex, /* 34 */
- NULL, /* 35 */
- TclGetLong, /* 36 */
+ 0, /* 35 */
+ 0, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
- NULL, /* 43 */
+ 0, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
- NULL, /* 47 */
- NULL, /* 48 */
- NULL, /* 49 */
+ 0, /* 47 */
+ 0, /* 48 */
+ 0, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
- NULL, /* 52 */
+ 0, /* 52 */
TclInvokeObjectCommand, /* 53 */
TclInvokeStringCommand, /* 54 */
TclIsProc, /* 55 */
- NULL, /* 56 */
- NULL, /* 57 */
+ 0, /* 56 */
+ 0, /* 57 */
TclLookupVar, /* 58 */
- NULL, /* 59 */
+ 0, /* 59 */
TclNeedSpace, /* 60 */
TclNewProcBodyObj, /* 61 */
TclObjCommandComplete, /* 62 */
TclObjInterpProc, /* 63 */
TclObjInvoke, /* 64 */
- NULL, /* 65 */
- NULL, /* 66 */
- NULL, /* 67 */
- NULL, /* 68 */
+ 0, /* 65 */
+ 0, /* 66 */
+ 0, /* 67 */
+ 0, /* 68 */
TclpAlloc, /* 69 */
- NULL, /* 70 */
- NULL, /* 71 */
- NULL, /* 72 */
- NULL, /* 73 */
+ 0, /* 70 */
+ 0, /* 71 */
+ 0, /* 72 */
+ 0, /* 73 */
TclpFree, /* 74 */
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
TclpGetTime, /* 77 */
TclpGetTimeZone, /* 78 */
- NULL, /* 79 */
- NULL, /* 80 */
+ 0, /* 79 */
+ 0, /* 80 */
TclpRealloc, /* 81 */
- NULL, /* 82 */
- NULL, /* 83 */
- NULL, /* 84 */
- NULL, /* 85 */
- NULL, /* 86 */
- NULL, /* 87 */
+ 0, /* 82 */
+ 0, /* 83 */
+ 0, /* 84 */
+ 0, /* 85 */
+ 0, /* 86 */
+ 0, /* 87 */
TclPrecTraceProc, /* 88 */
TclPreventAliasLoop, /* 89 */
- NULL, /* 90 */
+ 0, /* 90 */
TclProcCleanupProc, /* 91 */
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
- NULL, /* 94 */
- NULL, /* 95 */
+ 0, /* 94 */
+ 0, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
- NULL, /* 99 */
- NULL, /* 100 */
+ 0, /* 99 */
+ 0, /* 100 */
TclSetPreInitScript, /* 101 */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
TclSockMinimumBuffers, /* 104 */
- NULL, /* 105 */
- NULL, /* 106 */
- NULL, /* 107 */
+ 0, /* 105 */
+ 0, /* 106 */
+ 0, /* 107 */
TclTeardownNamespace, /* 108 */
TclUpdateReturnInfo, /* 109 */
- NULL, /* 110 */
+ 0, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
Tcl_AppendExportList, /* 112 */
Tcl_CreateNamespace, /* 113 */
@@ -208,13 +190,13 @@ TclIntStubs tclIntStubs = {
Tcl_SetNamespaceResolvers, /* 131 */
TclpHasSockets, /* 132 */
TclpGetDate, /* 133 */
- NULL, /* 134 */
- NULL, /* 135 */
- NULL, /* 136 */
- NULL, /* 137 */
+ 0, /* 134 */
+ 0, /* 135 */
+ 0, /* 136 */
+ 0, /* 137 */
TclGetEnv, /* 138 */
- NULL, /* 139 */
- NULL, /* 140 */
+ 0, /* 139 */
+ 0, /* 140 */
TclpGetCwd, /* 141 */
TclSetByteCodeFromAny, /* 142 */
TclAddLiteralObj, /* 143 */
@@ -228,52 +210,52 @@ TclIntStubs tclIntStubs = {
TclRegExpRangeUniChar, /* 151 */
TclSetLibraryPath, /* 152 */
TclGetLibraryPath, /* 153 */
- NULL, /* 154 */
- NULL, /* 155 */
+ 0, /* 154 */
+ 0, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
- TclSetStartupScriptFileName, /* 158 */
- TclGetStartupScriptFileName, /* 159 */
- NULL, /* 160 */
+ 0, /* 158 */
+ 0, /* 159 */
+ 0, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
TclGetInstructionTable, /* 163 */
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
- TclSetStartupScriptPath, /* 167 */
- TclGetStartupScriptPath, /* 168 */
+ 0, /* 167 */
+ 0, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
- NULL, /* 174 */
+ 0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
- NULL, /* 180 */
- NULL, /* 181 */
+ 0, /* 178 */
+ 0, /* 179 */
+ 0, /* 180 */
+ 0, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
- NULL, /* 184 */
- NULL, /* 185 */
- NULL, /* 186 */
- NULL, /* 187 */
- NULL, /* 188 */
- NULL, /* 189 */
- NULL, /* 190 */
- NULL, /* 191 */
- NULL, /* 192 */
- NULL, /* 193 */
- NULL, /* 194 */
- NULL, /* 195 */
- NULL, /* 196 */
- NULL, /* 197 */
+ 0, /* 184 */
+ 0, /* 185 */
+ 0, /* 186 */
+ 0, /* 187 */
+ 0, /* 188 */
+ 0, /* 189 */
+ 0, /* 190 */
+ 0, /* 191 */
+ 0, /* 192 */
+ 0, /* 193 */
+ 0, /* 194 */
+ 0, /* 195 */
+ 0, /* 196 */
+ 0, /* 197 */
TclObjGetFrame, /* 198 */
- NULL, /* 199 */
+ 0, /* 199 */
TclpObjRemoveDirectory, /* 200 */
TclpObjCopyDirectory, /* 201 */
TclpObjCreateDirectory, /* 202 */
@@ -283,9 +265,9 @@ TclIntStubs tclIntStubs = {
TclpObjStat, /* 206 */
TclpObjAccess, /* 207 */
TclpOpenFileChannel, /* 208 */
- NULL, /* 209 */
- NULL, /* 210 */
- NULL, /* 211 */
+ 0, /* 209 */
+ 0, /* 210 */
+ 0, /* 211 */
TclpFindExecutable, /* 212 */
TclGetObjNameOfExecutable, /* 213 */
TclSetObjNameOfExecutable, /* 214 */
@@ -293,16 +275,16 @@ TclIntStubs tclIntStubs = {
TclStackFree, /* 216 */
TclPushStackFrame, /* 217 */
TclPopStackFrame, /* 218 */
- NULL, /* 219 */
- NULL, /* 220 */
- NULL, /* 221 */
- NULL, /* 222 */
- NULL, /* 223 */
+ 0, /* 219 */
+ 0, /* 220 */
+ 0, /* 221 */
+ 0, /* 222 */
+ 0, /* 223 */
TclGetPlatform, /* 224 */
TclTraceDictPath, /* 225 */
TclObjBeingDeleted, /* 226 */
TclSetNsPath, /* 227 */
- TclObjInterpProcCore, /* 228 */
+ 0, /* 228 */
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
@@ -310,32 +292,33 @@ TclIntStubs tclIntStubs = {
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
- TclBackgroundException, /* 236 */
- NULL, /* 237 */
- NULL, /* 238 */
- NULL, /* 239 */
- NULL, /* 240 */
- NULL, /* 241 */
- NULL, /* 242 */
+ 0, /* 236 */
+ TclResetCancellation, /* 237 */
+ TclNRInterpProc, /* 238 */
+ TclNRInterpProcCore, /* 239 */
+ TclNRRunCallbacks, /* 240 */
+ TclNREvalObjEx, /* 241 */
+ TclNREvalObjv, /* 242 */
TclDbDumpActiveObjects, /* 243 */
- NULL, /* 244 */
- NULL, /* 245 */
- NULL, /* 246 */
- NULL, /* 247 */
- NULL, /* 248 */
+ TclGetNamespaceChildTable, /* 244 */
+ TclGetNamespaceCommandTable, /* 245 */
+ TclInitRewriteEnsemble, /* 246 */
+ TclResetRewriteEnsemble, /* 247 */
+ TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
+ TclSetSlaveCancelFlags, /* 250 */
};
-TclIntPlatStubs tclIntPlatStubs = {
+static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
- NULL,
+ 0,
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
- NULL, /* 5 */
+ 0, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
@@ -352,27 +335,27 @@ TclIntPlatStubs tclIntPlatStubs = {
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
- NULL, /* 5 */
+ 0, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
- NULL, /* 10 */
+ 0, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
- NULL, /* 16 */
- NULL, /* 17 */
+ 0, /* 16 */
+ 0, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
- NULL, /* 21 */
+ 0, /* 21 */
TclpCreateTempFile, /* 22 */
TclpGetTZName, /* 23 */
TclWinNoBackslash, /* 24 */
- NULL, /* 25 */
+ 0, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
@@ -384,7 +367,7 @@ TclIntPlatStubs tclIntPlatStubs = {
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
- NULL, /* 5 */
+ 0, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
@@ -402,9 +385,9 @@ TclIntPlatStubs tclIntPlatStubs = {
#endif /* MACOSX */
};
-TclPlatStubs tclPlatStubs = {
+static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
- NULL,
+ 0,
#ifdef __WIN32__ /* WIN */
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
@@ -415,9 +398,9 @@ TclPlatStubs tclPlatStubs = {
#endif /* MACOSX */
};
-TclTomMathStubs tclTomMathStubs = {
+const TclTomMathStubs tclTomMathStubs = {
TCL_STUB_MAGIC,
- NULL,
+ 0,
TclBN_epoch, /* 0 */
TclBN_revision, /* 1 */
TclBN_mp_add, /* 2 */
@@ -483,13 +466,13 @@ TclTomMathStubs tclTomMathStubs = {
TclBN_mp_set_int, /* 62 */
};
-static TclStubHooks tclStubHooks = {
+static const TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs
};
-TclStubs tclStubs = {
+const TclStubs tclStubs = {
TCL_STUB_MAGIC,
&tclStubHooks,
Tcl_PkgProvideEx, /* 0 */
@@ -505,7 +488,7 @@ TclStubs tclStubs = {
Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- NULL, /* 9 */
+ 0, /* 9 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_CreateFileHandler, /* 9 */
@@ -514,7 +497,7 @@ TclStubs tclStubs = {
Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- NULL, /* 10 */
+ 0, /* 10 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_DeleteFileHandler, /* 10 */
@@ -679,7 +662,7 @@ TclStubs tclStubs = {
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- NULL, /* 167 */
+ 0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_GetOpenFile, /* 167 */
@@ -704,7 +687,7 @@ TclStubs tclStubs = {
Tcl_IsSafe, /* 185 */
Tcl_JoinPath, /* 186 */
Tcl_LinkVar, /* 187 */
- NULL, /* 188 */
+ 0, /* 188 */
Tcl_MakeFileChannel, /* 189 */
Tcl_MakeSafe, /* 190 */
Tcl_MakeTcpClientChannel, /* 191 */
@@ -801,7 +784,7 @@ TclStubs tclStubs = {
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
Tcl_SetMainLoop, /* 284 */
- NULL, /* 285 */
+ 0, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */
Tcl_CreateThreadExitHandler, /* 288 */
@@ -1096,6 +1079,56 @@ TclStubs tclStubs = {
Tcl_AppendFormatToObj, /* 577 */
Tcl_ObjPrintf, /* 578 */
Tcl_AppendPrintfToObj, /* 579 */
+ Tcl_CancelEval, /* 580 */
+ Tcl_Canceled, /* 581 */
+ Tcl_CreatePipe, /* 582 */
+ Tcl_NRCreateCommand, /* 583 */
+ Tcl_NREvalObj, /* 584 */
+ Tcl_NREvalObjv, /* 585 */
+ Tcl_NRCmdSwap, /* 586 */
+ Tcl_NRAddCallback, /* 587 */
+ Tcl_NRCallObjProc, /* 588 */
+ Tcl_GetFSDeviceFromStat, /* 589 */
+ Tcl_GetFSInodeFromStat, /* 590 */
+ Tcl_GetModeFromStat, /* 591 */
+ Tcl_GetLinkCountFromStat, /* 592 */
+ Tcl_GetUserIdFromStat, /* 593 */
+ Tcl_GetGroupIdFromStat, /* 594 */
+ Tcl_GetDeviceTypeFromStat, /* 595 */
+ Tcl_GetAccessTimeFromStat, /* 596 */
+ Tcl_GetModificationTimeFromStat, /* 597 */
+ Tcl_GetChangeTimeFromStat, /* 598 */
+ Tcl_GetSizeFromStat, /* 599 */
+ Tcl_GetBlocksFromStat, /* 600 */
+ Tcl_GetBlockSizeFromStat, /* 601 */
+ Tcl_SetEnsembleParameterList, /* 602 */
+ Tcl_GetEnsembleParameterList, /* 603 */
+ Tcl_ParseArgsObjv, /* 604 */
+ Tcl_GetErrorLine, /* 605 */
+ Tcl_SetErrorLine, /* 606 */
+ Tcl_TransferResult, /* 607 */
+ Tcl_InterpActive, /* 608 */
+ Tcl_BackgroundException, /* 609 */
+ Tcl_ZlibDeflate, /* 610 */
+ Tcl_ZlibInflate, /* 611 */
+ Tcl_ZlibCRC32, /* 612 */
+ Tcl_ZlibAdler32, /* 613 */
+ Tcl_ZlibStreamInit, /* 614 */
+ Tcl_ZlibStreamGetCommandName, /* 615 */
+ Tcl_ZlibStreamEof, /* 616 */
+ Tcl_ZlibStreamChecksum, /* 617 */
+ Tcl_ZlibStreamPut, /* 618 */
+ Tcl_ZlibStreamGet, /* 619 */
+ Tcl_ZlibStreamClose, /* 620 */
+ Tcl_ZlibStreamReset, /* 621 */
+ Tcl_SetStartupScript, /* 622 */
+ Tcl_GetStartupScript, /* 623 */
+ Tcl_CloseEx, /* 624 */
+ Tcl_NRExprObj, /* 625 */
+ Tcl_NRSubstObj, /* 626 */
+ Tcl_LoadFile, /* 627 */
+ Tcl_FindSymbol, /* 628 */
+ Tcl_FSUnloadFile, /* 629 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index 1f5b436..f569820 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -18,24 +18,21 @@
* including the rest of the stub functions.
*/
-#ifndef USE_TCL_STUBS
#define USE_TCL_STUBS
-#endif
-#undef USE_TCL_STUB_PROCS
#include "tclInt.h"
-/*
- * Tcl_InitStubs and stub table pointers are built as exported symbols.
- */
+MODULE_SCOPE const TclStubs *tclStubsPtr;
+MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr;
+MODULE_SCOPE const TclIntStubs *tclIntStubsPtr;
+MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr;
-TclStubs *tclStubsPtr = NULL;
-TclPlatStubs *tclPlatStubsPtr = NULL;
-TclIntStubs *tclIntStubsPtr = NULL;
-TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
-TclTomMathStubs* tclTomMathStubsPtr = NULL;
+const TclStubs *tclStubsPtr = NULL;
+const TclPlatStubs *tclPlatStubsPtr = NULL;
+const TclIntStubs *tclIntStubsPtr = NULL;
+const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
-static TclStubs *
+static const TclStubs *
HasStubSupport(
Tcl_Interp *interp)
{
@@ -45,9 +42,9 @@ HasStubSupport(
return iPtr->stubTable;
}
- interp->result =
- "This interpreter does not support stubs-enabled extensions.";
- interp->freeProc = TCL_STATIC;
+ iPtr->result =
+ (char *)"This interpreter does not support stubs-enabled extensions.";
+ iPtr->freeProc = TCL_STATIC;
return NULL;
}
@@ -78,17 +75,13 @@ static int isDigit(const int c)
*----------------------------------------------------------------------
*/
-#ifdef Tcl_InitStubs
-#undef Tcl_InitStubs
-#endif
-
-CONST char *
+MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
- CONST char *version,
+ const char *version,
int exact)
{
- CONST char *actualVersion = NULL;
+ const char *actualVersion = NULL;
ClientData pkgData = NULL;
/*
@@ -107,14 +100,14 @@ Tcl_InitStubs(
return NULL;
}
if (exact) {
- CONST char *p = version;
+ const char *p = version;
int count = 0;
while (*p) {
count += !isDigit(*p++);
}
if (count == 1) {
- CONST char *q = actualVersion;
+ const char *q = actualVersion;
p = version;
while (*p && (*p == *q)) {
@@ -132,7 +125,7 @@ Tcl_InitStubs(
}
}
}
- tclStubsPtr = (TclStubs*)pkgData;
+ tclStubsPtr = (TclStubs *) pkgData;
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
@@ -148,58 +141,9 @@ Tcl_InitStubs(
}
/*
- *----------------------------------------------------------------------
- *
- * TclTomMathInitStubs --
- *
- * Initializes the Stubs table for Tcl's subset of libtommath
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * This procedure should not be called directly, but rather through
- * the TclTomMath_InitStubs macro, to insure that the Stubs table
- * matches the header files used in compilation.
- *
- *----------------------------------------------------------------------
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
*/
-
-#ifdef TclTomMathInitializeStubs
-#undef TclTomMathInitializeStubs
-#endif
-
-CONST char*
-TclTomMathInitializeStubs(
- Tcl_Interp* interp, /* Tcl interpreter */
- CONST char* version, /* Tcl version needed */
- int epoch, /* Stubs table epoch from the header files */
- int revision /* Stubs table revision number from the
- * header files */
-) {
- 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);
- TclTomMathStubs* stubsPtr = (TclTomMathStubs*) pkgClientData;
- if (actualVersion == NULL) {
- return NULL;
- }
- if (pkgClientData == NULL) {
- errMsg = "missing stub table pointer";
- } else if ((stubsPtr->tclBN_epoch)() != epoch) {
- errMsg = "epoch number mismatch";
- } else if ((stubsPtr->tclBN_revision)() != revision) {
- errMsg = "requires a later revision";
- } else {
- tclTomMathStubsPtr = stubsPtr;
- return actualVersion;
- }
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error loading ", packageName,
- " (requested version ", version,
- ", actual version ", actualVersion,
- "): ", errMsg, NULL);
- return NULL;
-}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 130bc38..bac0c7f 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -17,9 +17,12 @@
#include <math.h>
-#define TCL_TEST
+#undef STATIC_BUILD
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-
+#include "tclOO.h"
/*
* Required for Testregexp*Cmd
*/
@@ -40,6 +43,17 @@
*/
/*
+ * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
+ * Tcltest_Init declaration is in the source file itself, which is only
+ * accessed when we are building a library.
+ */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+EXTERN int Tcltest_Init(Tcl_Interp *interp);
+EXTERN int Tcltest_SafeInit(Tcl_Interp *interp);
+
+/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
@@ -139,7 +153,6 @@ static TestChannel *firstDetached;
* Forward declarations for procedures defined later in this file:
*/
-int Tcltest_Init(Tcl_Interp *interp);
static int AsyncHandlerProc(ClientData clientData,
Tcl_Interp *interp, int code);
#ifdef TCL_THREADS
@@ -157,11 +170,11 @@ static void CmdTraceDeleteProc(
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
ClientData cmdClientData, int argc,
- char **argv);
+ const char *argv[]);
static void CmdTraceProc(ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
- int argc, char **argv);
+ int argc, const char *argv[]);
static int CreatedCommandProc(
ClientData clientData, Tcl_Interp *interp,
int argc, const char **argv);
@@ -202,36 +215,6 @@ static void ObjTraceDeleteProc(ClientData clientData);
static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void SpecialFree(char *blockPtr);
static int StaticInitProc(Tcl_Interp *interp);
-#undef USE_OBSOLETE_FS_HOOKS
-#ifdef USE_OBSOLETE_FS_HOOKS
-static int TestaccessprocCmd(ClientData dummy,
- Tcl_Interp *interp, int argc, const char **argv);
-static int TestopenfilechannelprocCmd(
- ClientData dummy, Tcl_Interp *interp, int argc,
- const char **argv);
-static int TeststatprocCmd(ClientData dummy,
- Tcl_Interp *interp, int argc, const char **argv);
-static int PretendTclpAccess(const char *path, int mode);
-static int TestAccessProc1(const char *path, int mode);
-static int TestAccessProc2(const char *path, int mode);
-static int TestAccessProc3(const char *path, int mode);
-static Tcl_Channel PretendTclpOpenFileChannel(
- Tcl_Interp *interp, const char *fileName,
- const char *modeString, int permissions);
-static Tcl_Channel TestOpenFileChannelProc1(
- Tcl_Interp *interp, const char *fileName,
- const char *modeString, int permissions);
-static Tcl_Channel TestOpenFileChannelProc2(
- Tcl_Interp *interp, const char *fileName,
- const char *modeString, int permissions);
-static Tcl_Channel TestOpenFileChannelProc3(
- Tcl_Interp *interp, const char *fileName,
- const char *modeString, int permissions);
-static int PretendTclpStat(const char *path, struct stat *buf);
-static int TestStatProc1(const char *path, struct stat *buf);
-static int TestStatProc2(const char *path, struct stat *buf);
-static int TestStatProc3(const char *path, struct stat *buf);
-#endif
static int TestasyncCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestcmdinfoCmd(ClientData dummy,
@@ -323,6 +306,9 @@ static int TestexitmainloopCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestpanicCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestfinexitObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -338,7 +324,7 @@ static int TestregexpObjCmd(ClientData dummy,
static int TestreturnObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static void TestregexpXflags(char *string,
+static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
static int TestsaveresultCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
@@ -382,101 +368,85 @@ static int TestSimpleFilesystemObjCmd(
static void TestReport(const char *cmd, Tcl_Obj *arg1,
Tcl_Obj *arg2);
static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr);
-static int TestReportStat(Tcl_Obj *path, Tcl_StatBuf *buf);
-static int TestReportAccess(Tcl_Obj *path, int mode);
-static Tcl_Channel TestReportOpenFileChannel(
- Tcl_Interp *interp, Tcl_Obj *fileName,
- int mode, int permissions);
-static int TestReportMatchInDirectory(Tcl_Interp *interp,
- Tcl_Obj *resultPtr, Tcl_Obj *dirPtr,
- const char *pattern, Tcl_GlobTypeData *types);
-static int TestReportChdir(Tcl_Obj *dirName);
-static int TestReportLstat(Tcl_Obj *path, Tcl_StatBuf *buf);
-static int TestReportCopyFile(Tcl_Obj *src, Tcl_Obj *dst);
-static int TestReportDeleteFile(Tcl_Obj *path);
-static int TestReportRenameFile(Tcl_Obj *src, Tcl_Obj *dst);
-static int TestReportCreateDirectory(Tcl_Obj *path);
-static int TestReportCopyDirectory(Tcl_Obj *src,
- Tcl_Obj *dst, Tcl_Obj **errorPtr);
-static int TestReportRemoveDirectory(Tcl_Obj *path,
- int recursive, Tcl_Obj **errorPtr);
-static int TestReportLoadFile(Tcl_Interp *interp,
- Tcl_Obj *fileName, Tcl_LoadHandle *handlePtr,
- Tcl_FSUnloadFileProc **unloadProcPtr);
-static Tcl_Obj * TestReportLink(Tcl_Obj *path,
- Tcl_Obj *to, int linkType);
-static const char ** TestReportFileAttrStrings(
- Tcl_Obj *fileName, Tcl_Obj **objPtrRef);
-static int TestReportFileAttrsGet(Tcl_Interp *interp,
- int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef);
-static int TestReportFileAttrsSet(Tcl_Interp *interp,
- int index, Tcl_Obj *fileName, Tcl_Obj *objPtr);
-static int TestReportUtime(Tcl_Obj *fileName,
- struct utimbuf *tval);
-static int TestReportNormalizePath(Tcl_Interp *interp,
- Tcl_Obj *pathPtr, int nextCheckpoint);
-static int TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr);
-static void TestReportFreeInternalRep(ClientData clientData);
-static ClientData TestReportDupInternalRep(ClientData clientData);
-
-static int SimpleStat(Tcl_Obj *path, Tcl_StatBuf *buf);
-static int SimpleAccess(Tcl_Obj *path, int mode);
-static Tcl_Channel SimpleOpenFileChannel(Tcl_Interp *interp,
- Tcl_Obj *fileName, int mode, int permissions);
-static Tcl_Obj * SimpleListVolumes(void);
-static int SimplePathInFilesystem(
- Tcl_Obj *pathPtr, ClientData *clientDataPtr);
+static Tcl_FSStatProc TestReportStat;
+static Tcl_FSAccessProc TestReportAccess;
+static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel;
+static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory;
+static Tcl_FSChdirProc TestReportChdir;
+static Tcl_FSLstatProc TestReportLstat;
+static Tcl_FSCopyFileProc TestReportCopyFile;
+static Tcl_FSDeleteFileProc TestReportDeleteFile;
+static Tcl_FSRenameFileProc TestReportRenameFile;
+static Tcl_FSCreateDirectoryProc TestReportCreateDirectory;
+static Tcl_FSCopyDirectoryProc TestReportCopyDirectory;
+static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory;
+static Tcl_FSLoadFileProc TestReportLoadFile;
+static Tcl_FSLinkProc TestReportLink;
+static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings;
+static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet;
+static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet;
+static Tcl_FSUtimeProc TestReportUtime;
+static Tcl_FSNormalizePathProc TestReportNormalizePath;
+static Tcl_FSPathInFilesystemProc TestReportInFilesystem;
+static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep;
+static Tcl_FSDupInternalRepProc TestReportDupInternalRep;
+
+static Tcl_FSStatProc SimpleStat;
+static Tcl_FSAccessProc SimpleAccess;
+static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel;
+static Tcl_FSListVolumesProc SimpleListVolumes;
+static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
-static int SimpleMatchInDirectory(
- Tcl_Interp *interp, Tcl_Obj *resultPtr,
- Tcl_Obj *dirPtr, const char *pattern,
- Tcl_GlobTypeData *types);
+static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static int TestNumUtfCharsCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestNRELevels(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
-static Tcl_Filesystem testReportingFilesystem = {
+static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
- &TestReportInFilesystem, /* path in */
- &TestReportDupInternalRep,
- &TestReportFreeInternalRep,
+ TestReportInFilesystem, /* path in */
+ TestReportDupInternalRep,
+ TestReportFreeInternalRep,
NULL, /* native to norm */
NULL, /* convert to native */
- &TestReportNormalizePath,
+ TestReportNormalizePath,
NULL, /* path type */
NULL, /* separator */
- &TestReportStat,
- &TestReportAccess,
- &TestReportOpenFileChannel,
- &TestReportMatchInDirectory,
- &TestReportUtime,
- &TestReportLink,
+ TestReportStat,
+ TestReportAccess,
+ TestReportOpenFileChannel,
+ TestReportMatchInDirectory,
+ TestReportUtime,
+ TestReportLink,
NULL /* list volumes */,
- &TestReportFileAttrStrings,
- &TestReportFileAttrsGet,
- &TestReportFileAttrsSet,
- &TestReportCreateDirectory,
- &TestReportRemoveDirectory,
- &TestReportDeleteFile,
- &TestReportCopyFile,
- &TestReportRenameFile,
- &TestReportCopyDirectory,
- &TestReportLstat,
- &TestReportLoadFile,
+ TestReportFileAttrStrings,
+ TestReportFileAttrsGet,
+ TestReportFileAttrsSet,
+ TestReportCreateDirectory,
+ TestReportRemoveDirectory,
+ TestReportDeleteFile,
+ TestReportCopyFile,
+ TestReportRenameFile,
+ TestReportCopyDirectory,
+ TestReportLstat,
+ TestReportLoadFile,
NULL /* cwd */,
- &TestReportChdir
+ TestReportChdir
};
-static Tcl_Filesystem simpleFilesystem = {
+static const Tcl_Filesystem simpleFilesystem = {
"simple",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
- &SimplePathInFilesystem,
+ SimplePathInFilesystem,
NULL,
NULL,
/* No internal to normalized, since we don't create any
@@ -490,14 +460,14 @@ static Tcl_Filesystem simpleFilesystem = {
NULL,
NULL,
NULL,
- &SimpleStat,
- &SimpleAccess,
- &SimpleOpenFileChannel,
- &SimpleMatchInDirectory,
+ SimpleStat,
+ SimpleAccess,
+ SimpleOpenFileChannel,
+ SimpleMatchInDirectory,
NULL,
/* We choose not to support symbolic links inside our vfs's */
NULL,
- &SimpleListVolumes,
+ SimpleListVolumes,
NULL,
NULL,
NULL,
@@ -521,15 +491,6 @@ static Tcl_Filesystem simpleFilesystem = {
/*
- * External (platform specific) initialization routine, these declarations
- * explicitly don't use EXTERN since this code does not get compiled into the
- * library:
- */
-
-extern int TclplatformtestInit(Tcl_Interp *interp);
-extern int TclThread_Init(Tcl_Interp *interp);
-
-/*
*----------------------------------------------------------------------
*
* Tcltest_Init --
@@ -557,11 +518,20 @@ Tcltest_Init(
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
- static const char *specialOptions[] = {
+ static const char *const specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
+ if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_OOInitStubs(interp) == NULL) {
+ return TCL_ERROR;
+ }
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
@@ -572,139 +542,141 @@ Tcltest_Init(
* Create additional commands and math functions for testing Tcl.
*/
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, NULL);
- Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL);
+ Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
- TestGetIndexFromObjStructObjCmd, (ClientData) 0, NULL);
-#ifdef USE_OBSOLETE_FS_HOOKS
- Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
- NULL);
- Tcl_CreateCommand(interp, "testopenfilechannelproc",
- TestopenfilechannelprocCmd, (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
- NULL);
-#endif
- Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, NULL);
+ TestGetIndexFromObjStructObjCmd, NULL, NULL);
+ Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
- (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
- Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
+ Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
- (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, NULL);
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL);
+ Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd,
NULL, NULL);
Tcl_DStringInit(&dstring);
- Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
+ Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL,
NULL);
- Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
+ Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testevent", TesteventObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
- (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testhashsystemhash",
- TestHashSystemHashCmd, (ClientData) 0, NULL);
+ TestHashSystemHashCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
- TestgetvarfullnameCmd, (ClientData) 0, NULL);
+ TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
- (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, NULL);
- Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
- Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
(ClientData) TCL_LEAVE_ERR_MSG, NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
(ClientData) TCL_LEAVE_ERR_MSG, NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
- TestsetobjerrorcodeCmd, (ClientData) 0, NULL);
+ TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
- TestNumUtfCharsCmd, (ClientData) 0, NULL);
+ TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
- TesttranslatefilenameCmd, (ClientData) 0, NULL);
- Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, NULL);
+ TesttranslatefilenameCmd, NULL, NULL);
+ Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
- Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0,
+ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
- (ClientData) NULL, NULL);
+ NULL, NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
- (ClientData) NULL, NULL);
+ NULL, NULL);
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- (ClientData) 0);
+ NULL);
+
+ Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
+ NULL, NULL);
+ if (TclObjTest_Init(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Procbodytest_Init(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
#ifdef TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -750,6 +722,35 @@ Tcltest_Init(
return TclplatformtestInit(interp);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcltest_SafeInit --
+ *
+ * This procedure performs application-specific initialization. Most
+ * applications, especially those that incorporate additional packages,
+ * will have their own version of this procedure.
+ *
+ * Results:
+ * Returns a standard Tcl completion code, and leaves an error message in
+ * the interp's result if an error occurs.
+ *
+ * Side effects:
+ * Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcltest_SafeInit(
+ Tcl_Interp *interp) /* Interpreter for application. */
+{
+ if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ return TCL_ERROR;
+ }
+ return Procbodytest_SafeInit(interp);
+}
/*
*----------------------------------------------------------------------
@@ -779,7 +780,6 @@ TestasyncCmd(
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- char buf[TCL_INTEGER_SPACE];
if (argc < 2) {
wrongNumArgs:
@@ -790,17 +790,16 @@ TestasyncCmd(
if (argc != 3) {
goto wrongNumArgs;
}
- asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
+ asyncPtr = ckalloc(sizeof(TestAsyncHandler));
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
(ClientData) asyncPtr);
- asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
+ asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
strcpy(asyncPtr->command, argv[2]);
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
- TclFormatInt(buf, asyncPtr->id);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
while (firstHandler != NULL) {
@@ -808,7 +807,7 @@ TestasyncCmd(
firstHandler = asyncPtr->nextPtr;
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
- ckfree((char *) asyncPtr);
+ ckfree(asyncPtr);
}
return TCL_OK;
}
@@ -830,7 +829,7 @@ TestasyncCmd(
}
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
- ckfree((char *) asyncPtr);
+ ckfree(asyncPtr);
break;
}
} else if (strcmp(argv[1], "mark") == 0) {
@@ -848,7 +847,7 @@ TestasyncCmd(
break;
}
}
- Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
@@ -910,7 +909,7 @@ AsyncHandlerProc(
* invoked, it's possible. Better error checking is needed here.
*/
}
- ckfree((char *)cmd);
+ ckfree(cmd);
return code;
}
@@ -1017,13 +1016,13 @@ TestcmdinfoCmd(
info.proc = CmdProc2;
info.clientData = (ClientData) "new_command_data";
info.objProc = NULL;
- info.objClientData = (ClientData) NULL;
+ info.objClientData = NULL;
info.deleteProc = CmdDelProc2;
info.deleteData = (ClientData) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
- Tcl_SetResult(interp, "0", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
} else {
- Tcl_SetResult(interp, "1", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
@@ -1175,8 +1174,7 @@ TestcmdtraceCmd(
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
- cmdTrace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -1189,17 +1187,16 @@ TestcmdtraceCmd(
* Create a command trace then eval a script to check whether it is
* called. Note that this trace procedure removes itself as a further
* check of the robustness of the trace proc calling code in
- * TclExecuteByteCode.
+ * TclNRExecuteByteCode.
*/
- cmdTrace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
+ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
Tcl_Eval(interp, argv[2]);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
- cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
+ &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -1230,10 +1227,8 @@ TestcmdtraceCmd(
Tcl_Trace t1, t2;
Tcl_DStringInit(&buffer);
- t1 = Tcl_CreateTrace(interp, 1,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
- t2 = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
+ t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -1263,7 +1258,7 @@ CmdTraceProc(
ClientData cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
- char **argv) /* Argument strings. */
+ const char *argv[]) /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
@@ -1288,11 +1283,11 @@ CmdTraceDeleteProc(
ClientData cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
- char **argv) /* Argument strings. */
+ const char *argv[]) /* Argument strings. */
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
- * callback causes the for loop in TclExecuteByteCode that calls traces to
+ * callback causes the for loop in TclNRExecuteByteCode that calls traces to
* reference freed memory.
*/
@@ -1370,12 +1365,12 @@ TestcreatecommandCmd(
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",
- CreatedCommandProc, (ClientData) NULL, NULL);
+ CreatedCommandProc, NULL, NULL);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");
} else if (strcmp(argv[1], "create2") == 0) {
Tcl_CreateCommand(interp, "value:at:",
- CreatedCommandProc2, (ClientData) NULL, NULL);
+ CreatedCommandProc2, NULL, NULL);
} else if (strcmp(argv[1], "delete2") == 0) {
Tcl_DeleteCommand(interp, "value:at:");
} else {
@@ -1532,9 +1527,9 @@ TestdelCmd(
return TCL_ERROR;
}
- dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
+ dPtr = ckalloc(sizeof(DelCmd));
dPtr->interp = interp;
- dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
+ dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
@@ -1553,7 +1548,7 @@ DelCmdProc(
Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
ckfree(dPtr->deleteCmd);
- ckfree((char *) dPtr);
+ ckfree(dPtr);
return TCL_OK;
}
@@ -1561,12 +1556,12 @@ static void
DelDeleteProc(
ClientData clientData) /* String command to evaluate. */
{
- DelCmd *dPtr = (DelCmd *) clientData;
+ DelCmd *dPtr = clientData;
Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
- ckfree((char *) dPtr);
+ ckfree(dPtr);
}
/*
@@ -1768,13 +1763,13 @@ TestdstringCmd(
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
} else if (strcmp(argv[2], "free") == 0) {
- Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);
- strcpy(interp->result, "This is a malloc-ed string");
+ char *s = ckalloc(100);
+ strcpy(s, "This is a malloc-ed string");
+ Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
- interp->result = (char *) ckalloc(100);
- interp->result += 4;
- interp->freeProc = SpecialFree;
- strcpy(interp->result, "This is a specially-allocated string");
+ char *s = (char*)ckalloc(100) + 16;
+ strcpy(s, "This is a specially-allocated string");
+ Tcl_SetResult(interp, s, SpecialFree);
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
@@ -1783,13 +1778,11 @@ TestdstringCmd(
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(argv[1], "length") == 0) {
- char buf[TCL_INTEGER_SPACE];
if (argc != 2) {
goto wrongNumArgs;
}
- TclFormatInt(buf, Tcl_DStringLength(&dstring));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
@@ -1825,7 +1818,7 @@ TestdstringCmd(
static void SpecialFree(blockPtr)
char *blockPtr; /* Block to free. */
{
- ckfree(blockPtr - 4);
+ ckfree(blockPtr - 16);
}
/*
@@ -1855,9 +1848,9 @@ TestencodingObjCmd(
{
Tcl_Encoding encoding;
int index, length;
- char *string;
+ const char *string;
TclEncoding *encodingPtr;
- static const char *optionStrings[] = {
+ static const char *const optionStrings[] = {
"create", "delete", NULL
};
enum options {
@@ -1876,15 +1869,15 @@ TestencodingObjCmd(
if (objc != 5) {
return TCL_ERROR;
}
- encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
+ encodingPtr = ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
- encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ encodingPtr->toUtfCmd = ckalloc(length + 1);
memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
- encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ encodingPtr->fromUtfCmd = ckalloc(length + 1);
memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
string = Tcl_GetStringFromObj(objv[2], &length);
@@ -1979,12 +1972,11 @@ static void
EncodingFreeProc(
ClientData clientData) /* ClientData associated with type. */
{
- TclEncoding *encodingPtr;
+ TclEncoding *encodingPtr = clientData;
- encodingPtr = (TclEncoding *) clientData;
- ckfree((char *) encodingPtr->toUtfCmd);
- ckfree((char *) encodingPtr->fromUtfCmd);
- ckfree((char *) encodingPtr);
+ ckfree(encodingPtr->toUtfCmd);
+ ckfree(encodingPtr->fromUtfCmd);
+ ckfree(encodingPtr);
}
/*
@@ -2012,11 +2004,11 @@ TestevalexObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, flags;
- char *script;
+ const char *script;
flags = 0;
if (objc == 3) {
- char *global = Tcl_GetStringFromObj(objv[2], &length);
+ const char *global = Tcl_GetStringFromObj(objv[2], &length);
if (strcmp(global, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", global,
"\": must be global", NULL);
@@ -2105,11 +2097,11 @@ TesteventObjCmd(
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
- static const char *subcommands[] = { /* Possible subcommands */
+ static const char *const subcommands[] = { /* Possible subcommands */
"queue", "delete", NULL
};
int subCmdIndex; /* Index of the chosen subcommand */
- static const char *positions[] = { /* Possible queue positions */
+ static const char *const positions[] = { /* Possible queue positions */
"head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
@@ -2122,7 +2114,7 @@ TesteventObjCmd(
TestEvent *ev; /* Event to be queued */
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand",
@@ -2139,7 +2131,7 @@ TesteventObjCmd(
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
- ev = (TestEvent *) ckalloc(sizeof(TestEvent));
+ ev = ckalloc(sizeof(TestEvent));
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
@@ -2240,9 +2232,9 @@ TesteventDeleteProc(
* to remove */
{
TestEvent *ev; /* Event to examine */
- char *evNameStr;
+ const char *evNameStr;
Tcl_Obj *targetName; /* Name of the event(s) to delete */
- char *targetNameStr;
+ const char *targetNameStr;
if (event->proc != TesteventProc) {
return 0;
@@ -2668,7 +2660,7 @@ TestgetplatformCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- static const char *platformStrings[] = { "unix", "mac", "windows" };
+ static const char *const platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
platform = TclGetPlatform();
@@ -2997,7 +2989,7 @@ TestlinkCmd(
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
- stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
+ stringVar = ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
@@ -3104,7 +3096,7 @@ TestlinkCmd(
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
- stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
+ stringVar = ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
@@ -3219,10 +3211,10 @@ TestlocaleCmd(
Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
- char *locale;
+ const char *locale;
- static const char *optionStrings[] = {
- "ctype", "numeric", "time", "collate", "monetary",
+ static const char *const optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
static int lcTypes[] = {
@@ -3416,7 +3408,7 @@ CleanupTestSetassocdataTests(
ClientData clientData, /* Data to be released. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
- ckfree((char *) clientData);
+ ckfree(clientData);
}
/*
@@ -3443,7 +3435,7 @@ TestparserObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- char *script;
+ const char *script;
int length, dummy;
Tcl_Parse parse;
@@ -3499,7 +3491,7 @@ TestexprparserObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- char *script;
+ const char *script;
int length, dummy;
Tcl_Parse parse;
@@ -3560,7 +3552,7 @@ PrintParse(
Tcl_Parse *parsePtr) /* Parse structure to print out. */
{
Tcl_Obj *objPtr;
- char *typeString;
+ const char *typeString;
Tcl_Token *tokenPtr;
int i;
@@ -3687,7 +3679,7 @@ TestparsevarnameObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- char *script;
+ const char *script;
int append, length, dummy;
Tcl_Parse parse;
@@ -3755,10 +3747,10 @@ TestregexpObjCmd(
int i, ii, indices, stringLength, match, about;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
- char *string;
+ const char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
- static const char *options[] = {
+ static const char *const options[] = {
"-indices", "-nocase", "-about", "-expanded",
"-line", "-linestop", "-lineanchor",
"-xflags",
@@ -3778,7 +3770,7 @@ TestregexpObjCmd(
hasxflags = 0;
for (i = 1; i < objc; i++) {
- char *name;
+ const char *name;
int index;
name = Tcl_GetString(objv[i]);
@@ -3823,7 +3815,7 @@ TestregexpObjCmd(
endOfForLoop:
if (objc - i < hasxflags + 2 - about) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ "?-switch ...? exp string ?matchVar? ?subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
@@ -3863,7 +3855,7 @@ TestregexpObjCmd(
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
- char *varName;
+ const char *varName;
const char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
@@ -3878,7 +3870,7 @@ TestregexpObjCmd(
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
- char *varName;
+ const char *varName;
const char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
@@ -3947,10 +3939,8 @@ TestregexpObjCmd(
info.matches[ii].end - 1);
}
}
- valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
+ valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
- Tcl_AppendResult(interp, "couldn't set variable \"",
- Tcl_GetString(varPtr), "\"", NULL);
return TCL_ERROR;
}
}
@@ -3982,7 +3972,7 @@ TestregexpObjCmd(
static void
TestregexpXflags(
- char *string, /* The string of flags. */
+ const char *string, /* The string of flags. */
int length, /* The length of the string in bytes. */
int *cflagsPtr, /* compile flags word */
int *eflagsPtr) /* exec flags word */
@@ -4115,7 +4105,7 @@ TestsetassocdataCmd(
return TCL_ERROR;
}
- buf = ckalloc((unsigned) strlen(argv[2]) + 1);
+ buf = ckalloc(strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
@@ -4220,8 +4210,8 @@ TeststaticpkgCmd(
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
- (safe) ? StaticInitProc : NULL);
+ tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
+ StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
@@ -4423,7 +4413,7 @@ TestfeventCmd(
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?", NULL);
+ " option ?arg ...?", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "cmd") == 0) {
@@ -4498,10 +4488,51 @@ TestpanicCmd(
argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
- ckfree((char *)argString);
+ ckfree(argString);
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestfinexitObjCmd --
+ *
+ * Calls a variant of [exit] including the full finalization path.
+ *
+ * Results:
+ * Error, or doesn't return.
+ *
+ * Side effects:
+ * Exits application.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestfinexitObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int value;
+
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 1) {
+ value = 0;
+ } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_Finalize();
+ TclpExit(value);
+ /*NOTREACHED*/
+ return TCL_ERROR; /* Better not ever reach this! */
+}
static int
TestfileCmd(
@@ -4512,7 +4543,7 @@ TestfileCmd(
{
int force, i, j, result;
Tcl_Obj *error = NULL;
- char *subcmd;
+ const char *subcmd;
if (argc < 3) {
return TCL_ERROR;
@@ -4592,7 +4623,7 @@ TestgetvarfullnameCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- char *name, *arg;
+ const char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
Tcl_CallFrame *framePtr;
@@ -4682,8 +4713,8 @@ GetTimesCmd(
fprintf(stderr, "alloc & free 100000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
- ckfree((char *) objPtr);
+ objPtr = ckalloc(sizeof(Tcl_Obj));
+ ckfree(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4691,10 +4722,10 @@ GetTimesCmd(
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
- objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
+ objv = ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
- objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
+ objv[i] = ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4704,7 +4735,7 @@ GetTimesCmd(
fprintf(stderr, "free 5000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
- ckfree((char *) objv[i]);
+ ckfree(objv[i]);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4730,7 +4761,7 @@ GetTimesCmd(
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
- ckfree((char *) objv);
+ ckfree(objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
@@ -4987,10 +5018,11 @@ TestsaveresultCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
+ Interp* iPtr = (Interp*) interp;
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
- static const char *optionStrings[] = {
+ static const char *const optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
@@ -5029,7 +5061,7 @@ TestsaveresultCmd(
break;
}
case RESULT_DYNAMIC:
- Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
+ Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
objPtr = Tcl_NewStringObj("object result", -1);
@@ -5055,7 +5087,7 @@ TestsaveresultCmd(
switch ((enum options) index) {
case RESULT_DYNAMIC: {
- int present = interp->freeProc == TestsaveresultFree;
+ int present = iPtr->freeProc == TestsaveresultFree;
int called = freeCount;
Tcl_AppendElement(interp, called ? "called" : "notCalled");
@@ -5094,201 +5126,6 @@ TestsaveresultFree(
{
freeCount++;
}
-#ifdef USE_OBSOLETE_FS_HOOKS
-
-/*
- *----------------------------------------------------------------------
- *
- * TeststatprocCmd --
- *
- * Implements the "testTclStatProc" cmd that is used to test the
- * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TeststatprocCmd(
- ClientData dummy, /* Not used. */
- register Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
-{
- TclStatProc_ *proc;
- int retVal;
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option arg\"", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[2], "TclpStat") == 0) {
- proc = PretendTclpStat;
- } else if (strcmp(argv[2], "TestStatProc1") == 0) {
- proc = TestStatProc1;
- } else if (strcmp(argv[2], "TestStatProc2") == 0) {
- proc = TestStatProc2;
- } else if (strcmp(argv[2], "TestStatProc3") == 0) {
- proc = TestStatProc3;
- } else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": "
- "must be TclpStat, "
- "TestStatProc1, TestStatProc2, or TestStatProc3", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[1], "insert") == 0) {
- if (proc == PretendTclpStat) {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": "
- "must be "
- "TestStatProc1, TestStatProc2, or TestStatProc3", NULL);
- return TCL_ERROR;
- }
- retVal = TclStatInsertProc(proc);
- } else if (strcmp(argv[1], "delete") == 0) {
- retVal = TclStatDeleteProc(proc);
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1], "\": "
- "must be insert or delete", NULL);
- return TCL_ERROR;
- }
-
- if (retVal == TCL_ERROR) {
- Tcl_AppendResult(interp, "\"", argv[2], "\": "
- "could not be ", argv[1], "ed", NULL);
- }
-
- return retVal;
-}
-
-static int
-PretendTclpStat(
- const char *path,
- struct stat *buf)
-{
- int ret;
- Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
-#ifdef TCL_WIDE_INT_IS_LONG
- Tcl_IncrRefCount(pathPtr);
- ret = TclpObjStat(pathPtr, buf);
- Tcl_DecrRefCount(pathPtr);
- return ret;
-#else /* TCL_WIDE_INT_IS_LONG */
- Tcl_StatBuf realBuf;
- Tcl_IncrRefCount(pathPtr);
- ret = TclpObjStat(pathPtr, &realBuf);
- Tcl_DecrRefCount(pathPtr);
- if (ret != -1) {
-# define OUT_OF_RANGE(x) \
- (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
- ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
-#if defined(__GNUC__) && __GNUC__ >= 2
-/*
- * Workaround gcc warning of "comparison is always false due to limited range of
- * data type" in this macro by checking max type size, and when necessary ANDing
- * with the complement of ULONG_MAX instead of the comparison:
- */
-# define OUT_OF_URANGE(x) \
- ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
- (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
-#else
-# define OUT_OF_URANGE(x) \
- (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
-#endif
-
- /*
- * Perform the result-buffer overflow check manually.
- *
- * Note that ino_t/ino64_t is unsigned...
- */
-
- if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)
-# ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- || OUT_OF_RANGE(realBuf.st_blocks)
-# endif
- ) {
-# ifdef EOVERFLOW
- errno = EOVERFLOW;
-# else
-# ifdef EFBIG
- errno = EFBIG;
-# else
-# error "what error should be returned for a value out of range?"
-# endif
-# endif
- return -1;
- }
-
-# undef OUT_OF_RANGE
-# undef OUT_OF_URANGE
-
- /*
- * Copy across all supported fields, with possible type coercions on
- * those fields that change between the normal and lf64 versions of
- * the stat structure (on Solaris at least.) This is slow when the
- * structure sizes coincide, but that's what you get for mixing
- * interfaces...
- */
-
- buf->st_mode = realBuf.st_mode;
- buf->st_ino = (ino_t) realBuf.st_ino;
- buf->st_dev = realBuf.st_dev;
- buf->st_rdev = realBuf.st_rdev;
- buf->st_nlink = realBuf.st_nlink;
- buf->st_uid = realBuf.st_uid;
- buf->st_gid = realBuf.st_gid;
- buf->st_size = (off_t) realBuf.st_size;
- buf->st_atime = realBuf.st_atime;
- buf->st_mtime = realBuf.st_mtime;
- buf->st_ctime = realBuf.st_ctime;
-# ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- buf->st_blksize = realBuf.st_blksize;
-# endif
-# ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- buf->st_blocks = (blkcnt_t) realBuf.st_blocks;
-# endif
- }
- return ret;
-#endif /* TCL_WIDE_INT_IS_LONG */
-}
-
-static int
-TestStatProc1(
- const char *path,
- struct stat *buf)
-{
- memset(buf, 0, sizeof(struct stat));
- buf->st_size = 1234;
- return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
-}
-
-static int
-TestStatProc2(
- const char *path,
- struct stat *buf)
-{
- memset(buf, 0, sizeof(struct stat));
- buf->st_size = 2345;
- return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
-}
-
-static int
-TestStatProc3(
- const char *path,
- struct stat *buf)
-{
- memset(buf, 0, sizeof(struct stat));
- buf->st_size = 3456;
- return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
-}
-#endif
/*
*----------------------------------------------------------------------
@@ -5314,14 +5151,15 @@ TestmainthreadCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- if (argc == 1) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
- Tcl_SetObjResult(interp, idObj);
- return TCL_OK;
- } else {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
- return TCL_ERROR;
- }
+ if (argc == 1) {
+ Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
+
+ Tcl_SetObjResult(interp, idObj);
+ return TCL_OK;
+ } else {
+ Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ return TCL_ERROR;
+ }
}
/*
@@ -5332,7 +5170,7 @@ TestmainthreadCmd(
* A main loop set by TestsetmainloopCmd below.
*
* Results:
- * None.
+ * None.
*
* Side effects:
* Event handlers could do anything.
@@ -5406,309 +5244,6 @@ TestexitmainloopCmd(
exitMainLoop = 1;
return TCL_OK;
}
-#ifdef USE_OBSOLETE_FS_HOOKS
-
-/*
- *----------------------------------------------------------------------
- *
- * TestaccessprocCmd --
- *
- * Implements the "testTclAccessProc" cmd that is used to test the
- * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestaccessprocCmd(
- ClientData dummy, /* Not used. */
- register Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
-{
- TclAccessProc_ *proc;
- int retVal;
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option arg\"", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[2], "TclpAccess") == 0) {
- proc = PretendTclpAccess;
- } else if (strcmp(argv[2], "TestAccessProc1") == 0) {
- proc = TestAccessProc1;
- } else if (strcmp(argv[2], "TestAccessProc2") == 0) {
- proc = TestAccessProc2;
- } else if (strcmp(argv[2], "TestAccessProc3") == 0) {
- proc = TestAccessProc3;
- } else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": "
- "must be TclpAccess, "
- "TestAccessProc1, TestAccessProc2, or TestAccessProc3", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[1], "insert") == 0) {
- if (proc == PretendTclpAccess) {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": must be "
- "TestAccessProc1, TestAccessProc2, or TestAccessProc3"
- NULL);
- return TCL_ERROR;
- }
- retVal = TclAccessInsertProc(proc);
- } else if (strcmp(argv[1], "delete") == 0) {
- retVal = TclAccessDeleteProc(proc);
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1], "\": "
- "must be insert or delete", NULL);
- return TCL_ERROR;
- }
-
- if (retVal == TCL_ERROR) {
- Tcl_AppendResult(interp, "\"", argv[2], "\": "
- "could not be ", argv[1], "ed", NULL);
- }
-
- return retVal;
-}
-
-static int
-PretendTclpAccess(
- const char *path,
- int mode)
-{
- int ret;
- Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
- Tcl_IncrRefCount(pathPtr);
- ret = TclpObjAccess(pathPtr, mode);
- Tcl_DecrRefCount(pathPtr);
- return ret;
-}
-
-static int
-TestAccessProc1(
- const char *path,
- int mode)
-{
- return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);
-}
-
-static int
-TestAccessProc2(
- const char *path,
- int mode)
-{
- return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);
-}
-
-static int
-TestAccessProc3(
- const char *path,
- int mode)
-{
- return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestopenfilechannelprocCmd --
- *
- * Implements the "testTclOpenFileChannelProc" cmd that is used to test
- * the 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C
- * Apis.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestopenfilechannelprocCmd(
- ClientData dummy, /* Not used. */
- register Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
-{
- TclOpenFileChannelProc_ *proc;
- int retVal;
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option arg\"", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {
- proc = PretendTclpOpenFileChannel;
- } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {
- proc = TestOpenFileChannelProc1;
- } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {
- proc = TestOpenFileChannelProc2;
- } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {
- proc = TestOpenFileChannelProc3;
- } else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": "
- "must be TclpOpenFileChannel, "
- "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or "
- "TestOpenFileChannelProc3", NULL);
- return TCL_ERROR;
- }
-
- if (strcmp(argv[1], "insert") == 0) {
- if (proc == PretendTclpOpenFileChannel) {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": "
- "must be "
- "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or "
- "TestOpenFileChannelProc3", NULL);
- return TCL_ERROR;
- }
- retVal = TclOpenFileChannelInsertProc(proc);
- } else if (strcmp(argv[1], "delete") == 0) {
- retVal = TclOpenFileChannelDeleteProc(proc);
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1], "\": "
- "must be insert or delete", NULL);
- return TCL_ERROR;
- }
-
- if (retVal == TCL_ERROR) {
- Tcl_AppendResult(interp, "\"", argv[2], "\": "
- "could not be ", argv[1], "ed", NULL);
- }
-
- return retVal;
-}
-
-static Tcl_Channel
-PretendTclpOpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- const char *fileName, /* Name of file to open. */
- const char *modeString, /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
-{
- Tcl_Channel ret;
- int mode, seekFlag;
- Tcl_Obj *pathPtr;
- mode = TclGetOpenMode(interp, modeString, &seekFlag);
- if (mode == -1) {
- return NULL;
- }
- pathPtr = Tcl_NewStringObj(fileName, -1);
- Tcl_IncrRefCount(pathPtr);
- ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
- Tcl_DecrRefCount(pathPtr);
- if (ret != NULL) {
- if (seekFlag) {
- if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
- if (interp != NULL) {
- Tcl_AppendResult(interp,
- "could not seek to end of file while opening \"",
- fileName, "\": ", Tcl_PosixError(interp), NULL);
- }
- Tcl_Close(NULL, ret);
- return NULL;
- }
- }
- }
- return ret;
-}
-
-static Tcl_Channel
-TestOpenFileChannelProc1(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- const char *fileName, /* Name of file to open. */
- const char *modeString, /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
-{
- const char *expectname = "testOpenFileChannel1%.fil";
- Tcl_DString ds;
-
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(1, &expectname, &ds);
-
- if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
- Tcl_DStringFree(&ds);
- return (PretendTclpOpenFileChannel(interp,
- "__testOpenFileChannel1%__.fil",
- modeString, permissions));
- } else {
- Tcl_DStringFree(&ds);
- return NULL;
- }
-}
-
-static Tcl_Channel
-TestOpenFileChannelProc2(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- const char *fileName, /* Name of file to open. */
- const char *modeString, /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
-{
- const char *expectname = "testOpenFileChannel2%.fil";
- Tcl_DString ds;
-
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(1, &expectname, &ds);
-
- if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
- Tcl_DStringFree(&ds);
- return (PretendTclpOpenFileChannel(interp,
- "__testOpenFileChannel2%__.fil",
- modeString, permissions));
- } else {
- Tcl_DStringFree(&ds);
- return (NULL);
- }
-}
-
-static Tcl_Channel
-TestOpenFileChannelProc3(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- const char *fileName, /* Name of file to open. */
- const char *modeString, /* A list of POSIX open modes or a string such
- * as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
-{
- const char *expectname = "testOpenFileChannel3%.fil";
- Tcl_DString ds;
-
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(1, &expectname, &ds);
-
- if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
- Tcl_DStringFree(&ds);
- return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
- modeString, permissions));
- } else {
- Tcl_DStringFree(&ds);
- return (NULL);
- }
-}
-#endif
/*
*----------------------------------------------------------------------
@@ -5774,7 +5309,7 @@ TestChannelCmd(
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
- ckfree((char *) curPtr);
+ ckfree(curPtr);
break;
}
}
@@ -5844,7 +5379,7 @@ TestChannelCmd(
/* Remember the channel in the pool of detached channels */
- det = (TestChannel *) ckalloc(sizeof(TestChannel));
+ det = ckalloc(sizeof(TestChannel));
det->chan = chan;
det->nextPtr = firstDetached;
firstDetached = det;
@@ -6014,7 +5549,7 @@ TestChannelCmd(
return TCL_ERROR;
}
- TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
+ TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan));
Tcl_AppendResult(interp, buf, NULL);
return TCL_OK;
}
@@ -6242,8 +5777,7 @@ TestChannelEventCmd(
return TCL_ERROR;
}
- esPtr = (EventScriptRecord *) ckalloc((unsigned)
- sizeof(EventScriptRecord));
+ esPtr = ckalloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
@@ -6300,7 +5834,7 @@ TestChannelEventCmd(
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
- ckfree((char *) esPtr);
+ ckfree(esPtr);
return TCL_OK;
}
@@ -6341,7 +5875,7 @@ TestChannelEventCmd(
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
- ckfree((char *) esPtr);
+ ckfree(esPtr);
}
statePtr->scriptRecordPtr = NULL;
return TCL_OK;
@@ -6417,7 +5951,7 @@ TestWrongNumArgsObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
- char *msg;
+ const char *msg;
if (objc < 3) {
/*
@@ -6472,7 +6006,7 @@ TestGetIndexFromObjStructObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *ary[] = {
+ const char *const ary[] = {
"a", "b", "c", "d", "e", "f", NULL, NULL
};
int idx,target;
@@ -6527,7 +6061,7 @@ TestFilesystemObjCmd(
Tcl_Obj *const objv[])
{
int res, boolVal;
- char *msg;
+ const char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
@@ -6543,7 +6077,7 @@ TestFilesystemObjCmd(
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetResult(interp, msg, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
return res;
}
@@ -6809,7 +6343,7 @@ TestReportRemoveDirectory(
errorPtr);
}
-static const char **
+static const char *const *
TestReportFileAttrStrings(
Tcl_Obj *fileName,
Tcl_Obj **objPtrRef)
@@ -6899,7 +6433,7 @@ TestSimpleFilesystemObjCmd(
Tcl_Obj *const objv[])
{
int res, boolVal;
- char *msg;
+ const char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
@@ -6915,7 +6449,7 @@ TestSimpleFilesystemObjCmd(
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetResult(interp, msg, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
return res;
}
@@ -7081,7 +6615,7 @@ TestHashSystemHashCmd(
int objc,
Tcl_Obj *const objv[])
{
- static Tcl_HashKeyType hkType = {
+ static const Tcl_HashKeyType hkType = {
TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
NULL, NULL, NULL, NULL
};
@@ -7102,14 +6636,14 @@ TestHashSystemHashCmd(
}
for (i=0 ; i<limit ; i++) {
- hPtr = Tcl_CreateHashEntry(&hash, (char *) INT2PTR(i), &isNew);
+ hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
- Tcl_SetHashValue(hPtr, (ClientData) INT2PTR(i+42));
+ Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
if (hash.numEntries != limit) {
@@ -7162,7 +6696,6 @@ TestgetintCmd(
return TCL_ERROR;
} else {
int val, i, total=0;
- char buf[TCL_INTEGER_SPACE];
for (i=1 ; i<argc ; i++) {
if (Tcl_GetInt(interp, argv[i], &val) != TCL_OK) {
@@ -7170,12 +6703,48 @@ TestgetintCmd(
}
total += val;
}
- TclFormatInt(buf, total);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
return TCL_OK;
}
}
+static int
+TestNRELevels(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ static ptrdiff_t *refDepth = NULL;
+ ptrdiff_t depth;
+ Tcl_Obj *levels[6];
+ int i = 0;
+ NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
+
+ if (refDepth == NULL) {
+ refDepth = &depth;
+ }
+
+ depth = (refDepth - &depth);
+
+ levels[0] = Tcl_NewIntObj(depth);
+ levels[1] = Tcl_NewIntObj(iPtr->numLevels);
+ levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
+ - iPtr->execEnvPtr->execStackPtr->stackWords);
+
+ while (cbPtr) {
+ i++;
+ cbPtr = cbPtr->nextPtr;
+ }
+ levels[5] = Tcl_NewIntObj(i);
+
+ Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -7219,14 +6788,14 @@ TestconcatobjCmd(
list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
Tcl_ListObjLength(NULL, list1Ptr, &len);
if (list1Ptr->bytes != NULL) {
- ckfree((char *) list1Ptr->bytes);
+ ckfree(list1Ptr->bytes);
list1Ptr->bytes = NULL;
}
list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
Tcl_ListObjLength(NULL, list2Ptr, &len);
if (list2Ptr->bytes != NULL) {
- ckfree((char *) list2Ptr->bytes);
+ ckfree(list2Ptr->bytes);
list2Ptr->bytes = NULL;
}
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 37286e3..92c278f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -14,6 +14,9 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
#include "tommath.h"
@@ -34,7 +37,6 @@ static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
const char *string, int *indexPtr);
static void SetVarToObj(int varIndex, Tcl_Obj *objPtr);
-int TclObjTest_Init(Tcl_Interp *interp);
static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int TestbooleanobjCmd(ClientData dummy,
@@ -55,8 +57,8 @@ static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
typedef struct TestString {
int numChars;
- size_t allocated;
- size_t uallocated;
+ int allocated;
+ int maxChars;
Tcl_UniChar unicode[2];
} TestString;
@@ -85,24 +87,24 @@ TclObjTest_Init(
register int i;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- varPtr[i] = NULL;
+ varPtr[i] = NULL;
}
Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd,
- (ClientData) 0, NULL);
- Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL);
+ NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
- (ClientData) 0, NULL);
+ NULL, NULL);
return TCL_OK;
}
@@ -131,19 +133,18 @@ TestbignumobjCmd(
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
- const char * subcmds[] = {
- "set", "get", "mult10", "div10", NULL
+ const char *const subcmds[] = {
+ "set", "get", "mult10", "div10", NULL
};
enum options {
- BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
+ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
};
-
int index, varIndex;
- char* string;
+ const char *string;
mp_int bignumValue, newValue;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?...");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
@@ -285,7 +286,7 @@ TestbooleanobjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, boolValue;
- char *index, *subCmd;
+ const char *index, *subCmd;
if (objc < 3) {
wrongNumArgs:
@@ -383,7 +384,7 @@ TestdoubleobjCmd(
{
int varIndex;
double doubleValue;
- char *index, *subCmd, *string;
+ const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
@@ -440,9 +441,9 @@ TestdoubleobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
+ Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
} else {
- SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
+ SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
@@ -453,13 +454,13 @@ TestdoubleobjCmd(
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
- &doubleValue) != TCL_OK) {
+ &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
+ Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0);
} else {
- SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
+ SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
@@ -498,14 +499,14 @@ TestindexobjCmd(
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
- static const char *tablePtr[] = {"a", "b", "check", NULL};
+ static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
- VOID *tablePtr; /* Pointer to the table of strings */
- int offset; /* Offset between table entries */
- int index; /* Selected index into table. */
+ void *tablePtr; /* Pointer to the table of strings. */
+ int offset; /* Offset between table entries. */
+ int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
@@ -522,7 +523,7 @@ TestindexobjCmd(
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
+ indexRep = objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
@@ -544,7 +545,7 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
+ argv = ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
@@ -557,18 +558,17 @@ TestindexobjCmd(
* object, clear out the object's cached state.
*/
- if ( objv[3]->typePtr != NULL
- && !strcmp( "index", objv[3]->typePtr->name ) ) {
- indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
- if (indexRep->tablePtr == (VOID *) argv) {
- objv[3]->typePtr->freeIntRepProc(objv[3]);
- objv[3]->typePtr = NULL;
+ if (objv[3]->typePtr != NULL
+ && !strcmp("index", objv[3]->typePtr->name)) {
+ indexRep = objv[3]->internalRep.otherValuePtr;
+ if (indexRep->tablePtr == (void *) argv) {
+ TclFreeIntRep(objv[3]);
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
- ckfree((char *) argv);
+ ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
@@ -602,7 +602,7 @@ TestintobjCmd(
{
int intValue, varIndex, i;
long longValue;
- char *index, *subCmd, *string;
+ const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
@@ -690,7 +690,7 @@ TestintobjCmd(
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ((longValue == LONG_MAX)? "1" : "0"), -1);
+ ((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -742,13 +742,13 @@ TestintobjCmd(
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ &intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
+ Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
} else {
- SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
+ SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
@@ -759,13 +759,13 @@ TestintobjCmd(
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ &intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
+ Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
} else {
- SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
+ SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
@@ -898,8 +898,8 @@ TestobjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
- char *index, *subCmd, *string;
- Tcl_ObjType *targetType;
+ const char *index, *subCmd, *string;
+ const Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
@@ -909,106 +909,107 @@ TestobjCmd(
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
- if (objc != 4) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varIndex)) {
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- SetVarToObj(destIndex, varPtr[varIndex]);
+ if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
- } else if (strcmp(subCmd, "convert") == 0) {
- char *typeName;
- if (objc != 4) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varIndex)) {
+ } else if (strcmp(subCmd, "convert") == 0) {
+ const char *typeName;
+
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- typeName = Tcl_GetString(objv[3]);
- if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ typeName = Tcl_GetString(objv[3]);
+ if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", NULL);
- return TCL_ERROR;
- }
- if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
- != TCL_OK) {
- return TCL_ERROR;
- }
+ return TCL_ERROR;
+ }
+ if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
- if (objc != 4) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varIndex)) {
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
- if (objc != 2) {
- goto wrongNumArgs;
- }
- for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- if (varPtr[i] != NULL) {
- Tcl_DecrRefCount(varPtr[i]);
- varPtr[i] = NULL;
- }
- }
- } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
- if ( objc != 3 ) {
+ if (objc != 2) {
+ goto wrongNumArgs;
+ }
+ for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
+ if (varPtr[i] != NULL) {
+ Tcl_DecrRefCount(varPtr[i]);
+ varPtr[i] = NULL;
+ }
+ }
+ } else if (strcmp(subCmd, "invalidateStringRep") == 0) {
+ if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetString( objv[2] );
- if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- Tcl_InvalidateStringRep( varPtr[varIndex] );
- Tcl_SetObjResult( interp, varPtr[varIndex] );
+ Tcl_InvalidateStringRep(varPtr[varIndex]);
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "newobj") == 0) {
- if (objc != 3) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- SetVarToObj(varIndex, Tcl_NewObj());
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
const char *typeName;
/*
- * return an object containing the name of the argument's type
- * of internal rep. If none exists, return "none".
+ * Return an object containing the name of the argument's type of
+ * internal rep. If none exists, return "none".
*/
- if (objc != 3) {
- goto wrongNumArgs;
- }
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
@@ -1016,41 +1017,38 @@ TestobjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
- char buf[TCL_INTEGER_SPACE];
-
- if (objc != 3) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varIndex)) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- TclFormatInt(buf, varPtr[varIndex]->refCount);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
- if (objc != 3) {
- goto wrongNumArgs;
- }
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varIndex)) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
+ if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- varPtr[varIndex]->typePtr->name, -1);
- }
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ varPtr[varIndex]->typePtr->name, -1);
+ }
} else if (strcmp(subCmd, "types") == 0) {
- if (objc != 2) {
- goto wrongNumArgs;
- }
+ if (objc != 2) {
+ goto wrongNumArgs;
+ }
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
@@ -1090,14 +1088,14 @@ TeststringobjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex, option, i, length;
Tcl_UniChar *unicode;
+ int varIndex, option, i, length;
#define MAX_STRINGS 11
- char *index, *string, *strings[MAX_STRINGS+1];
+ const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
- static const char *options[] = {
+ static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
- "set", "set2", "setlength", "ualloc", "getunicode",
+ "set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
@@ -1199,8 +1197,9 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- strPtr = (TestString *)
- (varPtr[varIndex])->internalRep.otherValuePtr;
+ Tcl_ConvertToType(NULL, varPtr[varIndex],
+ Tcl_GetObjType("string"));
+ strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
@@ -1247,14 +1246,15 @@ TeststringobjCmd(
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
- case 9: /* ualloc */
+ case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- strPtr = (TestString *)
- (varPtr[varIndex])->internalRep.otherValuePtr;
- length = (int) strPtr->uallocated;
+ Tcl_ConvertToType(NULL, varPtr[varIndex],
+ Tcl_GetObjType("string"));
+ strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ length = strPtr->maxChars;
} else {
length = -1;
}
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 88bd1c3..a3f89f6 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -11,29 +11,31 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
/*
* name and version of this package
*/
-static char packageName[] = "procbodytest";
-static char packageVersion[] = "1.0";
+static const char packageName[] = "procbodytest";
+static const char packageVersion[] = "1.0";
/*
* Name of the commands exported by this package
*/
-static char procCommand[] = "proc";
+static const char procCommand[] = "proc";
/*
* this struct describes an entry in the table of command names and command
* procs
*/
-typedef struct CmdTable
-{
- char *cmdName; /* command name */
+typedef struct CmdTable {
+ const char *cmdName; /* command name */
Tcl_ObjCmdProc *proc; /* command proc */
int exportIt; /* if 1, export the command */
} CmdTable;
@@ -43,24 +45,22 @@ typedef struct CmdTable
*/
static int ProcBodyTestProcObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
- char *namespace, CONST CmdTable *cmdTablePtr);
-int Procbodytest_Init(Tcl_Interp * interp);
-int Procbodytest_SafeInit(Tcl_Interp * interp);
+ const char *namespace, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
* declarations of the enable command procedure.
*/
-static CONST CmdTable commands[] = {
+static const CmdTable commands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ 0, 0, 0 }
};
-static CONST CmdTable safeCommands[] = {
+static const CmdTable safeCommands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ 0, 0, 0 }
};
@@ -70,13 +70,13 @@ static CONST CmdTable safeCommands[] = {
*
* Procbodytest_Init --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "procbodytest" package.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -84,7 +84,7 @@ static CONST CmdTable safeCommands[] = {
int
Procbodytest_Init(
Tcl_Interp *interp) /* the Tcl interpreter for which the package
- * is initialized */
+ * is initialized */
{
return ProcBodyTestInitInternal(interp, 0);
}
@@ -94,13 +94,13 @@ Procbodytest_Init(
*
* Procbodytest_SafeInit --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "procbodytest" package.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -108,7 +108,7 @@ Procbodytest_Init(
int
Procbodytest_SafeInit(
Tcl_Interp *interp) /* the Tcl interpreter for which the package
- * is initialized */
+ * is initialized */
{
return ProcBodyTestInitInternal(interp, 1);
}
@@ -118,36 +118,38 @@ Procbodytest_SafeInit(
*
* RegisterCommand --
*
- * This function registers a command in the context of the given namespace.
+ * This function registers a command in the context of the given
+ * namespace.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
-static int RegisterCommand(interp, namespace, cmdTablePtr)
- Tcl_Interp* interp; /* the Tcl interpreter for which the operation
+static int
+RegisterCommand(
+ Tcl_Interp* interp, /* the Tcl interpreter for which the operation
* is performed */
- char *namespace; /* the namespace in which the command is
+ const char *namespace, /* the namespace in which the command is
* registered */
- CONST CmdTable *cmdTablePtr;/* the command to register */
+ const CmdTable *cmdTablePtr)/* the command to register */
{
char buf[128];
if (cmdTablePtr->exportIt) {
- sprintf(buf, "namespace eval %s { namespace export %s }",
- namespace, cmdTablePtr->cmdName);
- if (Tcl_Eval(interp, buf) != TCL_OK)
- return TCL_ERROR;
+ sprintf(buf, "namespace eval %s { namespace export %s }",
+ namespace, cmdTablePtr->cmdName);
+ if (Tcl_Eval(interp, buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
}
sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
-
return TCL_OK;
}
@@ -171,16 +173,16 @@ static int RegisterCommand(interp, namespace, cmdTablePtr)
static int
ProcBodyTestInitInternal(
Tcl_Interp *interp, /* the Tcl interpreter for which the package
- * is initialized */
+ * is initialized */
int isSafe) /* 1 if this is a safe interpreter */
{
- CONST CmdTable *cmdTablePtr;
+ const CmdTable *cmdTablePtr;
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
- if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
}
return Tcl_PkgProvide(interp, packageName, packageVersion);
@@ -226,7 +228,7 @@ ProcBodyTestProcObjCmd(
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
- char *fullName;
+ const char *fullName;
Tcl_Command procCmd;
Command *cmdPtr;
Proc *procPtr = NULL;
@@ -246,20 +248,20 @@ ProcBodyTestProcObjCmd(
fullName = Tcl_GetStringFromObj(objv[3], NULL);
procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG);
if (procCmd == NULL) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
cmdPtr = (Command *) procCmd;
/*
* check that this is a procedure and not a builtin command:
- * If a procedure, cmdPtr->objProc is TclObjInterpProc.
+ * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr).
*/
- if (cmdPtr->objProc != TclGetObjInterpProc()) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"command \"", fullName, "\" is not a Tcl procedure", NULL);
- return TCL_ERROR;
+ return TCL_ERROR;
}
/*
@@ -268,10 +270,9 @@ ProcBodyTestProcObjCmd(
procPtr = (Proc *) cmdPtr->objClientData;
if (procPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", fullName,
- "\" does not have a Proc struct!", NULL);
- return TCL_ERROR;
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"",
+ fullName, "\" does not have a Proc struct!", NULL);
+ return TCL_ERROR;
}
/*
@@ -280,10 +281,10 @@ ProcBodyTestProcObjCmd(
bodyObjPtr = TclNewProcBodyObj(procPtr);
if (bodyObjPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"failed to create a procbody object for procedure \"",
- fullName, "\"", NULL);
- return TCL_ERROR;
+ fullName, "\"", NULL);
+ return TCL_ERROR;
}
Tcl_IncrRefCount(bodyObjPtr);
@@ -293,7 +294,7 @@ ProcBodyTestProcObjCmd(
myobjv[3] = bodyObjPtr;
myobjv[4] = NULL;
- result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
+ result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv);
Tcl_DecrRefCount(bodyObjPtr);
return result;
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 8384107..d1f2691 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -5,6 +5,7 @@
* the real work is done in the platform dependent files.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 2008 by George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -24,7 +25,7 @@
typedef struct {
int num; /* Number of objects remembered */
int max; /* Max size of the array */
- char **list; /* List of pointers */
+ void **list; /* List of pointers */
} SyncObjRecord;
static SyncObjRecord keyRecord = {0, 0, NULL};
@@ -35,8 +36,8 @@ static SyncObjRecord condRecord = {0, 0, NULL};
* Prototypes of functions used only in this file.
*/
-static void ForgetSyncObject(char *objPtr, SyncObjRecord *recPtr);
-static void RememberSyncObject(char *objPtr,
+static void ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr);
+static void RememberSyncObject(void *objPtr,
SyncObjRecord *recPtr);
/*
@@ -82,21 +83,23 @@ Tcl_GetThreadData(
/*
* Initialize the key for this thread.
*/
- result = TclpThreadDataKeyGet(keyPtr);
+
+ result = TclThreadStorageKeyGet(keyPtr);
if (result == NULL) {
- result = ckalloc((size_t) size);
+ result = ckalloc(size);
memset(result, 0, (size_t) size);
- TclpThreadDataKeySet(keyPtr, result);
+ TclThreadStorageKeySet(keyPtr, result);
}
#else /* TCL_THREADS */
if (*keyPtr == NULL) {
- result = ckalloc((size_t) size);
- memset(result, 0, (size_t) size);
- *keyPtr = (Tcl_ThreadDataKey)result;
- RememberSyncObject((char *) keyPtr, &keyRecord);
+ result = ckalloc(size);
+ memset(result, 0, (size_t)size);
+ *keyPtr = result;
+ RememberSyncObject(keyPtr, &keyRecord);
+ } else {
+ result = *keyPtr;
}
- result = * (void **) keyPtr;
#endif /* TCL_THREADS */
return result;
}
@@ -120,17 +123,15 @@ Tcl_GetThreadData(
void *
TclThreadDataKeyGet(
- Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk, really
- * (pthread_key_t **) */
+ Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */
+
{
#ifdef TCL_THREADS
- return TclpThreadDataKeyGet(keyPtr);
+ return TclThreadStorageKeyGet(keyPtr);
#else /* TCL_THREADS */
- char *result = *(char **) keyPtr;
- return result;
+ return *keyPtr;
#endif /* TCL_THREADS */
}
-
/*
*----------------------------------------------------------------------
@@ -153,10 +154,10 @@ TclThreadDataKeyGet(
static void
RememberSyncObject(
- char *objPtr, /* Pointer to sync object */
+ void *objPtr, /* Pointer to sync object */
SyncObjRecord *recPtr) /* Record of sync objects */
{
- char **newList;
+ void **newList;
int i, j;
@@ -178,14 +179,14 @@ RememberSyncObject(
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
- newList = (char **) ckalloc(recPtr->max * sizeof(char *));
+ newList = ckalloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
}
}
if (recPtr->list != NULL) {
- ckfree((char *) recPtr->list);
+ ckfree(recPtr->list);
}
recPtr->list = newList;
recPtr->num = j;
@@ -214,7 +215,7 @@ RememberSyncObject(
static void
ForgetSyncObject(
- char *objPtr, /* Pointer to sync object */
+ void *objPtr, /* Pointer to sync object */
SyncObjRecord *recPtr) /* Record of sync objects */
{
int i;
@@ -248,7 +249,7 @@ void
TclRememberMutex(
Tcl_Mutex *mutexPtr)
{
- RememberSyncObject((char *)mutexPtr, &mutexRecord);
+ RememberSyncObject(mutexPtr, &mutexRecord);
}
/*
@@ -276,7 +277,7 @@ Tcl_MutexFinalize(
TclpFinalizeMutex(mutexPtr);
#endif
TclpMasterLock();
- ForgetSyncObject((char *) mutexPtr, &mutexRecord);
+ ForgetSyncObject(mutexPtr, &mutexRecord);
TclpMasterUnlock();
}
@@ -301,7 +302,7 @@ void
TclRememberCondition(
Tcl_Condition *condPtr)
{
- RememberSyncObject((char *) condPtr, &condRecord);
+ RememberSyncObject(condPtr, &condRecord);
}
/*
@@ -329,7 +330,7 @@ Tcl_ConditionFinalize(
TclpFinalizeCondition(condPtr);
#endif
TclpMasterLock();
- ForgetSyncObject((char *) condPtr, &condRecord);
+ ForgetSyncObject(condPtr, &condRecord);
TclpMasterUnlock();
}
@@ -353,7 +354,7 @@ Tcl_ConditionFinalize(
void
TclFinalizeThreadData(void)
{
- TclpFinalizeThreadDataThread();
+ TclFinalizeThreadDataThread();
}
/*
@@ -394,15 +395,15 @@ TclFinalizeSynchronization(void)
if (keyRecord.list != NULL) {
for (i=0 ; i<keyRecord.num ; i++) {
keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
- blockPtr = (void *) *keyPtr;
+ blockPtr = *keyPtr;
ckfree(blockPtr);
}
- ckfree((char *) keyRecord.list);
+ ckfree(keyRecord.list);
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
-
+
#ifdef TCL_THREADS
/*
* Call thread storage master cleanup.
@@ -417,7 +418,7 @@ TclFinalizeSynchronization(void)
}
}
if (mutexRecord.list != NULL) {
- ckfree((char *) mutexRecord.list);
+ ckfree(mutexRecord.list);
mutexRecord.list = NULL;
}
mutexRecord.max = 0;
@@ -430,7 +431,7 @@ TclFinalizeSynchronization(void)
}
}
if (condRecord.list != NULL) {
- ckfree((char *) condRecord.list);
+ ckfree(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
@@ -493,7 +494,7 @@ void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */
Tcl_Mutex *mutexPtr, /* Really (pthread_mutex_t **) */
- Tcl_Time *timePtr) /* Timeout on waiting period */
+ const Tcl_Time *timePtr) /* Timeout on waiting period */
{
}
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index bea85bd..ad1d510 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -35,7 +35,9 @@
*/
#define NOBJALLOC 800
-#define NOBJHIGH 1200
+
+/* Actual definition moved to tclInt.h */
+#define NOBJHIGH ALLOC_NOBJHIGH
/*
* The following union stores accounting information for each block including
@@ -95,7 +97,9 @@ typedef struct Bucket {
/*
* The following structure defines a cache of buckets and objs, of which there
- * will be (at most) one per thread.
+ * will be (at most) one per thread. Any changes need to be reflected in the
+ * struct AllocCache defined in tclInt.h, possibly also in the initialisation
+ * code in Tcl_CreateInterp().
*/
typedef struct Cache {
@@ -141,6 +145,26 @@ static Tcl_Mutex *objLockPtr;
static Cache sharedCache;
static Cache *sharedPtr = &sharedCache;
static Cache *firstCachePtr = &sharedCache;
+
+#if defined(HAVE_FAST_TSD)
+static __thread Cache *tcachePtr;
+
+# define GETCACHE(cachePtr) \
+ do { \
+ if (!tcachePtr) { \
+ tcachePtr = GetCache(); \
+ } \
+ (cachePtr) = tcachePtr; \
+ } while (0)
+#else
+# define GETCACHE(cachePtr) \
+ do { \
+ (cachePtr) = TclpGetAllocCache(); \
+ if ((cachePtr) == NULL) { \
+ (cachePtr) = GetCache(); \
+ } \
+ } while (0)
+#endif
/*
*----------------------------------------------------------------------
@@ -291,6 +315,7 @@ TclpAlloc(
register int bucket;
size_t size;
+#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
@@ -301,11 +326,9 @@ TclpAlloc(
return NULL;
}
}
+#endif
- cachePtr = TclpGetAllocCache();
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
+ GETCACHE(cachePtr);
/*
* Increment the requested size to include room for the Block structure.
@@ -317,7 +340,7 @@ TclpAlloc(
blockPtr = NULL;
size = reqSize + sizeof(Block);
#if RCHECK
- ++size;
+ size++;
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
@@ -328,13 +351,13 @@ TclpAlloc(
} else {
bucket = 0;
while (bucketInfo[bucket].blockSize < size) {
- ++bucket;
+ bucket++;
}
if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) {
blockPtr = cachePtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
- --cachePtr->buckets[bucket].numFree;
- ++cachePtr->buckets[bucket].numRemoves;
+ cachePtr->buckets[bucket].numFree--;
+ cachePtr->buckets[bucket].numRemoves++;
cachePtr->buckets[bucket].totalAssigned += reqSize;
}
}
@@ -372,10 +395,7 @@ TclpFree(
return;
}
- cachePtr = TclpGetAllocCache();
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
+ GETCACHE(cachePtr);
/*
* Get the block back from the user pointer and call system free directly
@@ -394,8 +414,8 @@ TclpFree(
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr;
- ++cachePtr->buckets[bucket].numFree;
- ++cachePtr->buckets[bucket].numInserts;
+ cachePtr->buckets[bucket].numFree++;
+ cachePtr->buckets[bucket].numInserts++;
if (cachePtr != sharedPtr &&
cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
@@ -434,6 +454,7 @@ TclpRealloc(
return TclpAlloc(reqSize);
}
+#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
@@ -444,11 +465,9 @@ TclpRealloc(
return NULL;
}
}
+#endif
- cachePtr = TclpGetAllocCache();
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
+ GETCACHE(cachePtr);
/*
* If the block is not a system block and fits in place, simply return the
@@ -459,7 +478,7 @@ TclpRealloc(
blockPtr = Ptr2Block(ptr);
size = reqSize + sizeof(Block);
#if RCHECK
- ++size;
+ size++;
#endif
bucket = blockPtr->sourceBucket;
if (bucket != NBUCKETS) {
@@ -512,18 +531,20 @@ TclpRealloc(
* May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if
* list is empty.
*
+ * Note:
+ * If this code is updated, the changes need to be reflected in the macro
+ * TclAllocObjStorageEx() defined in tclInt.h
+ *
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclThreadAllocObj(void)
{
- register Cache *cachePtr = TclpGetAllocCache();
+ register Cache *cachePtr;
register Tcl_Obj *objPtr;
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
+ GETCACHE(cachePtr);
/*
* Get this thread's obj list structure and move or allocate new objs if
@@ -564,7 +585,7 @@ TclThreadAllocObj(void)
objPtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
- --cachePtr->numObjects;
+ cachePtr->numObjects--;
return objPtr;
}
@@ -581,6 +602,10 @@ TclThreadAllocObj(void)
* Side effects:
* May move free Tcl_Obj's to shared list upon hitting high water mark.
*
+ * Note:
+ * If this code is updated, the changes need to be reflected in the macro
+ * TclAllocObjStorageEx() defined in tclInt.h
+ *
*----------------------------------------------------------------------
*/
@@ -588,11 +613,9 @@ void
TclThreadFreeObj(
Tcl_Obj *objPtr)
{
- Cache *cachePtr = TclpGetAllocCache();
+ Cache *cachePtr;
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
+ GETCACHE(cachePtr);
/*
* Get this thread's list and push on the free Tcl_Obj.
@@ -600,7 +623,7 @@ TclThreadFreeObj(
objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
- ++cachePtr->numObjects;
+ cachePtr->numObjects++;
/*
* If the number of free objects has exceeded the high water mark, move
@@ -792,14 +815,14 @@ LockBucket(
#if 0
if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) {
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
- ++cachePtr->buckets[bucket].numWaits;
- ++sharedPtr->buckets[bucket].numWaits;
+ cachePtr->buckets[bucket].numWaits++;
+ sharedPtr->buckets[bucket].numWaits++;
}
#else
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
#endif
- ++cachePtr->buckets[bucket].numLocks;
- ++sharedPtr->buckets[bucket].numLocks;
+ cachePtr->buckets[bucket].numLocks++;
+ sharedPtr->buckets[bucket].numLocks++;
}
static void
@@ -938,7 +961,7 @@ GetBlocks(
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
- --cachePtr->buckets[n].numFree;
+ cachePtr->buckets[n].numFree--;
break;
}
}
@@ -995,8 +1018,8 @@ TclFinalizeThreadAlloc(void)
unsigned int i;
for (i = 0; i < NBUCKETS; ++i) {
- TclpFreeAllocMutex(bucketInfo[i].lockPtr);
- bucketInfo[i].lockPtr = NULL;
+ TclpFreeAllocMutex(bucketInfo[i].lockPtr);
+ bucketInfo[i].lockPtr = NULL;
}
TclpFreeAllocMutex(objLockPtr);
diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c
index 3a905b5..4b09e1c 100644
--- a/generic/tclThreadJoin.c
+++ b/generic/tclThreadJoin.c
@@ -52,7 +52,7 @@ typedef struct JoinableThread {
TCL_DECLARE_MUTEX(joinMutex)
-static JoinableThread* firstThreadPtr;
+static JoinableThread *firstThreadPtr;
/*
*----------------------------------------------------------------------
@@ -201,7 +201,7 @@ TclJoinThread(
Tcl_ConditionFinalize(&threadPtr->cond);
Tcl_MutexFinalize(&threadPtr->threadMutex);
- ckfree((char *) threadPtr);
+ ckfree(threadPtr);
return TCL_OK;
}
@@ -230,7 +230,7 @@ TclRememberJoinableThread(
{
JoinableThread *threadPtr;
- threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread));
+ threadPtr = ckalloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c
index f1df888..f24e334 100644
--- a/generic/tclThreadStorage.c
+++ b/generic/tclThreadStorage.c
@@ -1,9 +1,11 @@
/*
* tclThreadStorage.c --
*
- * This file implements platform independent thread storage operations.
+ * This file implements platform independent thread storage operations to
+ * work around system limits on the number of thread-specific variables.
*
* Copyright (c) 2003-2004 by Joe Mistachkin
+ * Copyright (c) 2008 by George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -11,145 +13,171 @@
#include "tclInt.h"
-#if defined(TCL_THREADS)
+#ifdef TCL_THREADS
+#include <signal.h>
/*
- * This is the thread storage cache array and it's accompanying mutex. The
- * elements are pairs of thread Id and an associated hash table pointer; the
- * hash table being pointed to contains the thread storage for it's associated
- * thread. The purpose of this cache is to minimize the number of hash table
- * lookups in the master thread storage hash table.
- */
-
-static Tcl_Mutex threadStorageLock;
-
-/*
- * This is the struct used for a thread storage cache slot. It contains the
- * owning thread Id and the associated hash table pointer.
+ * IMPLEMENTATION NOTES:
+ *
+ * The primary idea is that we create one platform-specific TSD slot, and use
+ * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
+ * the table of TSD values. We don't use more than 1 platform-specific TSD
+ * slot, because there is a hard limit on the number of TSD slots. Valid key
+ * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
*/
-typedef struct ThreadStorage {
- Tcl_ThreadId id; /* the owning thread id */
- Tcl_HashTable *hashTablePtr;/* the hash table for the thread */
-} ThreadStorage;
-
/*
- * These are the prototypes for the custom hash table allocation functions
- * used by the thread storage subsystem.
+ * The master collection of information about TSDs. This is shared across the
+ * whole process, and includes the mutex used to protect it.
*/
-static Tcl_HashEntry * AllocThreadStorageEntry(Tcl_HashTable *tablePtr,
- void *keyPtr);
-static void FreeThreadStorageEntry(Tcl_HashEntry *hPtr);
-static Tcl_HashTable * ThreadStorageGetHashTable(Tcl_ThreadId id);
+static struct TSDMaster {
+ void *key; /* Key into the system TSD structure. The
+ * collection of Tcl TSD values for a
+ * particular thread will hang off the
+ * back-end of this. */
+ sig_atomic_t counter; /* The number of different Tcl TSDs used
+ * across *all* threads. This is a strictly
+ * increasing value. */
+ Tcl_Mutex mutex; /* Protection for the rest of this structure,
+ * which holds per-process data. */
+} tsdMaster = { NULL, 0, NULL };
/*
- * This is the hash key type for thread storage. We MUST use this in
- * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH
- * because these hash tables MAY be used by the threaded memory allocator.
+ * The type of the data held per thread in a system TSD.
*/
-static Tcl_HashKeyType tclThreadStorageHashKeyType = {
- TCL_HASH_KEY_TYPE_VERSION, /* version */
- TCL_HASH_KEY_SYSTEM_HASH | TCL_HASH_KEY_RANDOMIZE_HASH,
- /* flags */
- NULL, /* hashKeyProc */
- NULL, /* compareKeysProc */
- AllocThreadStorageEntry, /* allocEntryProc */
- FreeThreadStorageEntry /* freeEntryProc */
-};
+typedef struct TSDTable {
+ ClientData *tablePtr; /* The table of Tcl TSDs. */
+ sig_atomic_t allocated; /* The size of the table in the current
+ * thread. */
+} TSDTable;
/*
- * This is an invalid thread value.
+ * The actual type of Tcl_ThreadDataKey.
*/
-#define STORAGE_INVALID_THREAD (Tcl_ThreadId)0
+typedef union TSDUnion {
+ volatile sig_atomic_t offset;
+ /* The type is really an offset into the
+ * thread-local table of TSDs, which is this
+ * field. */
+ void *ptr; /* For alignment purposes only. Not actually
+ * accessed through this. */
+} TSDUnion;
/*
- * This is the value for an invalid thread storage key.
+ * Forward declarations of functions in this file.
*/
-#define STORAGE_INVALID_KEY 0
-
+static TSDTable * TSDTableCreate(void);
+static void TSDTableDelete(TSDTable *tsdTablePtr);
+static void TSDTableGrow(TSDTable *tsdTablePtr,
+ sig_atomic_t atLeast);
+
/*
- * This is the first valid key for use by external callers. All the values
- * below this are RESERVED for future use.
+ * Allocator and deallocator for a TSDTable structure.
*/
-#define STORAGE_FIRST_KEY 1
+static TSDTable *
+TSDTableCreate(void)
+{
+ TSDTable *tsdTablePtr;
+ sig_atomic_t i;
-/*
- * This is the default number of thread storage cache slots. This define may
- * need to be fine tuned for maximum performance.
- */
+ tsdTablePtr = TclpSysAlloc(sizeof(TSDTable), 0);
+ if (tsdTablePtr == NULL) {
+ Tcl_Panic("unable to allocate TSDTable");
+ }
-#define STORAGE_CACHE_SLOTS 97
+ tsdTablePtr->allocated = 8;
+ tsdTablePtr->tablePtr =
+ TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
+ if (tsdTablePtr->tablePtr == NULL) {
+ Tcl_Panic("unable to allocate TSDTable");
+ }
-/*
- * This is the master thread storage hash table. It is keyed on thread Id and
- * contains values that are hash tables for each thread. The thread specific
- * hash tables contain the actual thread storage.
- */
+ for (i = 0; i < tsdTablePtr->allocated; ++i) {
+ tsdTablePtr->tablePtr[i] = NULL;
+ }
-static Tcl_HashTable threadStorageHashTable;
+ return tsdTablePtr;
+}
-/*
- * This is the next thread data key value to use. We increment this everytime
- * we "allocate" one. It is initially set to 1 in TclInitThreadStorage.
- */
+static void
+TSDTableDelete(
+ TSDTable *tsdTablePtr)
+{
+ sig_atomic_t i;
-static int nextThreadStorageKey = STORAGE_INVALID_KEY;
+ for (i=0 ; i<tsdTablePtr->allocated ; i++) {
+ if (tsdTablePtr->tablePtr[i] != NULL) {
+ /*
+ * These values were allocated in Tcl_GetThreadData in tclThread.c
+ * and must now be deallocated or they will leak.
+ */
-/*
- * This is the master thread storage cache. Per Kevin Kenny's idea, this
- * prevents unnecessary lookups for threads that use a lot of thread storage.
- */
+ ckfree(tsdTablePtr->tablePtr[i]);
+ }
+ }
-static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS];
+ TclpSysFree(tsdTablePtr->tablePtr);
+ TclpSysFree(tsdTablePtr);
+}
/*
*----------------------------------------------------------------------
*
- * AllocThreadStorageEntry --
+ * TSDTableGrow --
*
- * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc).
- * We do this because the threaded memory allocator MAY use the thread
- * storage hash tables.
+ * This procedure makes the passed TSDTable grow to fit the atLeast
+ * value.
*
* Results:
- * The return value is a pointer to the created entry.
+ * None.
*
* Side effects:
- * None.
+ * The table is enlarged.
*
*----------------------------------------------------------------------
*/
-static Tcl_HashEntry *
-AllocThreadStorageEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key to store in the hash table entry. */
+static void
+TSDTableGrow(
+ TSDTable *tsdTablePtr,
+ sig_atomic_t atLeast)
{
- Tcl_HashEntry *hPtr;
+ sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
+ ClientData *newTablePtr;
+ sig_atomic_t i;
+
+ if (newAllocated <= atLeast) {
+ newAllocated = atLeast + 10;
+ }
+
+ newTablePtr = TclpSysRealloc(tsdTablePtr->tablePtr,
+ sizeof(ClientData) * newAllocated);
+ if (newTablePtr == NULL) {
+ Tcl_Panic("unable to reallocate TSDTable");
+ }
+
+ for (i = tsdTablePtr->allocated; i < newAllocated; ++i) {
+ newTablePtr[i] = NULL;
+ }
- hPtr = (Tcl_HashEntry *) TclpSysAlloc(sizeof(Tcl_HashEntry), 0);
- hPtr->key.oneWordValue = keyPtr;
- hPtr->clientData = NULL;
-
- return hPtr;
+ tsdTablePtr->allocated = newAllocated;
+ tsdTablePtr->tablePtr = newTablePtr;
}
/*
*----------------------------------------------------------------------
*
- * FreeThreadStorageEntry --
+ * TclThreadStorageKeyGet --
*
- * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do
- * this because the threaded memory allocator MAY use the thread storage
- * hash tables.
+ * This procedure gets the value associated with the passed key.
*
* Results:
- * None.
+ * A pointer value associated with the Tcl_ThreadDataKey or NULL.
*
* Side effects:
* None.
@@ -157,339 +185,138 @@ AllocThreadStorageEntry(
*----------------------------------------------------------------------
*/
-static void
-FreeThreadStorageEntry(
- Tcl_HashEntry *hPtr) /* Hash entry to free. */
+void *
+TclThreadStorageKeyGet(
+ Tcl_ThreadDataKey *dataKeyPtr)
{
- TclpSysFree((char *) hPtr);
+ TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
+ ClientData resultPtr = NULL;
+ TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
+ sig_atomic_t offset = keyPtr->offset;
+
+ if ((tsdTablePtr != NULL) && (offset > 0)
+ && (offset < tsdTablePtr->allocated)) {
+ resultPtr = tsdTablePtr->tablePtr[offset];
+ }
+ return resultPtr;
}
/*
*----------------------------------------------------------------------
*
- * ThreadStorageGetHashTable --
- *
- * This procedure returns a hash table pointer to be used for thread
- * storage for the specified thread.
+ * TclThreadStorageKeySet --
*
+ * This procedure set an association of value with the key passed. The
+ * associated value may be retrieved with TclThreadDataKeyGet().
+ *
* Results:
- * A hash table pointer for the specified thread, or NULL if the hash
- * table has not been created yet.
+ * None.
*
* Side effects:
- * May change an entry in the master thread storage cache to point to the
- * specified thread and it's associated hash table.
- *
- * Thread safety:
- * This function assumes that integer operations are safe (atomic)
- * on all (currently) supported Tcl platforms. Hence there are
- * places where shared integer arithmetic is done w/o protective locks.
+ * The thread-specific table may be created or reallocated.
*
*----------------------------------------------------------------------
*/
-static Tcl_HashTable *
-ThreadStorageGetHashTable(
- Tcl_ThreadId id) /* Id of thread to get hash table for */
+void
+TclThreadStorageKeySet(
+ Tcl_ThreadDataKey *dataKeyPtr,
+ void *value)
{
- int index = PTR2UINT(id) % STORAGE_CACHE_SLOTS;
- Tcl_HashEntry *hPtr;
- int isNew;
- Tcl_HashTable *hashTablePtr;
+ TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
+ TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
+
+ if (tsdTablePtr == NULL) {
+ tsdTablePtr = TSDTableCreate();
+ TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr);
+ }
/*
- * It's important that we pick up the hash table pointer BEFORE comparing
- * thread Id in case another thread is in the critical region changing
- * things out from under you.
- *
- * Thread safety: threadStorageCache is accessed w/o locks in order to
- * avoid serialization of all threads at this hot-spot. It is safe to
- * do this here because (threadStorageCache[index].id != id) test below
- * should be atomic on all (currently) supported platforms and there
- * are no devastatig side effects of the test.
- *
- * Note Valgrind users: this place will show up as a race-condition in
- * helgrind-tool output. To silence this warnings, define VALGRIND
- * symbol at compilation time.
+ * Get the lock while we check if this TSD is new or not. Note that this
+ * is the only place where Tcl_ThreadDataKey values are set. We use a
+ * double-checked lock to try to avoid having to grab this lock a lot,
+ * since it is on quite a few critical paths and will only get set once in
+ * each location.
*/
-#if !defined(VALGRIND)
- hashTablePtr = threadStorageCache[index].hashTablePtr;
- if (threadStorageCache[index].id != id) {
- Tcl_MutexLock(&threadStorageLock);
-#else
- Tcl_MutexLock(&threadStorageLock);
- hashTablePtr = threadStorageCache[index].hashTablePtr;
- if (threadStorageCache[index].id != id) {
-#endif
-
- /*
- * It's not in the cache, so we look it up...
- */
-
- hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char *) id);
-
- if (hPtr != NULL) {
+ if (keyPtr->offset == 0) {
+ Tcl_MutexLock(&tsdMaster.mutex);
+ if (keyPtr->offset == 0) {
/*
- * We found it, extract the hash table pointer.
+ * The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
*/
- hashTablePtr = Tcl_GetHashValue(hPtr);
- } else {
- /*
- * The thread specific hash table is not found.
- */
-
- hashTablePtr = NULL;
+ keyPtr->offset = ++tsdMaster.counter;
}
-
- if (hashTablePtr == NULL) {
- hashTablePtr = (Tcl_HashTable *)
- TclpSysAlloc(sizeof(Tcl_HashTable), 0);
-
- if (hashTablePtr == NULL) {
- Tcl_Panic("could not allocate thread specific hash table, "
- "TclpSysAlloc failed from ThreadStorageGetHashTable!");
- }
- Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS,
- &tclThreadStorageHashKeyType);
-
- /*
- * Add new thread storage hash table to the master hash table.
- */
-
- hPtr = Tcl_CreateHashEntry(&threadStorageHashTable, (char *) id,
- &isNew);
-
- if (hPtr == NULL) {
- Tcl_Panic("Tcl_CreateHashEntry failed from "
- "ThreadStorageGetHashTable!");
- }
- Tcl_SetHashValue(hPtr, hashTablePtr);
- }
-
- /*
- * Now, we put it in the cache since it is highly likely it will be
- * needed again shortly.
- */
-
- threadStorageCache[index].id = id;
- threadStorageCache[index].hashTablePtr = hashTablePtr;
-#if !defined(VALGRIND)
- Tcl_MutexUnlock(&threadStorageLock);
+ Tcl_MutexUnlock(&tsdMaster.mutex);
}
-#else
- }
- Tcl_MutexUnlock(&threadStorageLock);
-#endif
-
- return hashTablePtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitThreadStorage --
- *
- * Initializes the thread storage allocator.
- *
- * Results:
- * None.
- *
- * Side effects:
- * This procedure initializes the master hash table that maps thread ID
- * onto the individual index tables that map thread data key to thread
- * data. It also creates a cache that enables fast lookup of the thread
- * data block array for a recently executing thread without using
- * spinlocks.
- *
- * This procedure is called from an extremely early point in Tcl's
- * initialization. In particular, it may not use ckalloc/ckfree because they
- * may depend on thread-local storage (it uses TclpSysAlloc and TclpSysFree
- * instead). It may not depend on synchronization primitives - but no threads
- * other than the master thread have yet been launched.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitThreadStorage(void)
-{
- Tcl_InitCustomHashTable(&threadStorageHashTable, TCL_CUSTOM_TYPE_KEYS,
- &tclThreadStorageHashKeyType);
/*
- * We also initialize the cache.
+ * Check if this is the first time this Tcl_ThreadDataKey has been used
+ * with the current thread. Note that we don't need to hold a lock when
+ * doing this, as we are *definitely* the only point accessing this
+ * tsdTablePtr right now; it's thread-local.
*/
- memset((void*) &threadStorageCache, 0,
- sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);
+ if (keyPtr->offset >= tsdTablePtr->allocated) {
+ TSDTableGrow(tsdTablePtr, keyPtr->offset);
+ }
/*
- * Now, we set the first value to be used for a thread data key.
+ * Set the value in the Tcl thread-local variable.
*/
- nextThreadStorageKey = STORAGE_FIRST_KEY;
+ tsdTablePtr->tablePtr[keyPtr->offset] = value;
}
/*
*----------------------------------------------------------------------
*
- * TclpThreadDataKeyGet --
+ * TclFinalizeThreadDataThread --
*
- * This procedure returns a pointer to a block of thread local storage.
+ * This procedure finalizes the data for a single thread.
*
* Results:
- * A thread-specific pointer to the data structure, or NULL if the memory
- * has not been assigned to this key for this thread.
+ * None.
*
* Side effects:
- * None.
+ * The TSDTable is deleted/freed.
*
*----------------------------------------------------------------------
*/
-void *
-TclpThreadDataKeyGet(
- Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk, really
- * (int**) */
+void
+TclFinalizeThreadDataThread(void)
{
- Tcl_HashTable *hashTablePtr =
- ThreadStorageGetHashTable(Tcl_GetCurrentThread());
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr);
+ TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
- if (hPtr == NULL) {
- return NULL;
+ if (tsdTablePtr != NULL) {
+ TSDTableDelete(tsdTablePtr);
+ TclpThreadSetMasterTSD(tsdMaster.key, NULL);
}
- return Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
- * TclpThreadDataKeySet --
+ * TclInitializeThreadStorage --
*
- * This procedure sets the pointer to a block of thread local storage.
+ * This procedure initializes the TSD subsystem with per-platform code.
+ * This should be called before any Tcl threads are created.
*
* Results:
* None.
*
* Side effects:
- * Sets up the thread so future calls to TclpThreadDataKeyGet with this
- * key will return the data pointer.
+ * Allocates a system TSD.
*
*----------------------------------------------------------------------
*/
void
-TclpThreadDataKeySet(
- Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk, really
- * (pthread_key_t **) */
- void *data) /* Thread local storage */
+TclInitThreadStorage(void)
{
- Tcl_HashTable *hashTablePtr;
- Tcl_HashEntry *hPtr;
- int dummy;
-
- hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread());
- hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &dummy);
-
- Tcl_SetHashValue(hPtr, data);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFinalizeThreadDataThread --
- *
- * This procedure cleans up the thread storage hash table for the
- * current thread.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees all associated thread storage, all hash table entries for
- * the thread's thread storage, and the hash table itself.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpFinalizeThreadDataThread(void)
-{
- Tcl_ThreadId id = Tcl_GetCurrentThread();
- /* Id of the thread to finalize. */
- int index = PTR2UINT(id) % STORAGE_CACHE_SLOTS;
- Tcl_HashEntry *hPtr; /* Hash entry for current thread in master
- * table. */
- Tcl_HashTable* hashTablePtr;/* Pointer to the hash table holding TSD
- * blocks for the current thread*/
- Tcl_HashSearch search; /* Search object to walk the TSD blocks in the
- * designated thread */
- Tcl_HashEntry *hPtr2; /* Hash entry for a TSD block in the
- * designated thread. */
-
- Tcl_MutexLock(&threadStorageLock);
- hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id);
- if (hPtr == NULL) {
- hashTablePtr = NULL;
- } else {
- /*
- * We found it, extract the hash table pointer.
- */
-
- hashTablePtr = Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
-
- /*
- * Make sure cache entry for this thread is NULL.
- */
-
- if (threadStorageCache[index].id == id) {
- /*
- * We do not step on another thread's cache entry. This is
- * especially important if we are creating and exiting a lot of
- * threads.
- */
-
- threadStorageCache[index].id = STORAGE_INVALID_THREAD;
- threadStorageCache[index].hashTablePtr = NULL;
- }
- }
- Tcl_MutexUnlock(&threadStorageLock);
-
- /*
- * The thread's hash table has been extracted and removed from the master
- * hash table. Now clean up the thread.
- */
-
- if (hashTablePtr != NULL) {
- /*
- * Free all TSD
- */
-
- for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search); hPtr2 != NULL;
- hPtr2 = Tcl_NextHashEntry(&search)) {
- void *blockPtr = Tcl_GetHashValue(hPtr2);
-
- if (blockPtr != NULL) {
- /*
- * The block itself was allocated in Tcl_GetThreadData using
- * ckalloc; use ckfree to dispose of it.
- */
-
- ckfree(blockPtr);
- }
- }
-
- /*
- * Delete thread specific hash table and free the struct.
- */
-
- Tcl_DeleteHashTable(hashTablePtr);
- TclpSysFree((char *) hashTablePtr);
- }
+ tsdMaster.key = TclpThreadCreateKey();
}
/*
@@ -497,15 +324,14 @@ TclpFinalizeThreadDataThread(void)
*
* TclFinalizeThreadStorage --
*
- * This procedure cleans up the master thread storage hash table, all
- * thread specific hash tables, and the thread storage cache.
+ * This procedure cleans up the thread storage data key for all threads.
+ * IMPORTANT: All Tcl threads must be finalized before calling this!
*
* Results:
* None.
*
* Side effects:
- * The master thread storage hash table and thread storage cache are
- * reset to their initial (empty) state.
+ * Releases the thread data key.
*
*----------------------------------------------------------------------
*/
@@ -513,60 +339,11 @@ TclpFinalizeThreadDataThread(void)
void
TclFinalizeThreadStorage(void)
{
- Tcl_HashSearch search; /* We need to hit every thread with this
- * search. */
- Tcl_HashEntry *hPtr; /* Hash entry for current thread in master
- * table. */
- Tcl_MutexLock(&threadStorageLock);
-
- /*
- * We are going to delete the hash table for every thread now. This hash
- * table should be empty at this point, except for one entry for the
- * current thread.
- */
-
- for (hPtr = Tcl_FirstHashEntry(&threadStorageHashTable, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr);
-
- if (hashTablePtr != NULL) {
- /*
- * Delete thread specific hash table for the thread in question
- * and free the struct.
- */
-
- Tcl_DeleteHashTable(hashTablePtr);
- TclpSysFree((char *)hashTablePtr);
- }
-
- /*
- * Delete thread specific entry from master hash table.
- */
-
- Tcl_SetHashValue(hPtr, NULL);
- }
-
- Tcl_DeleteHashTable(&threadStorageHashTable);
-
- /*
- * Clear out the thread storage cache as well.
- */
-
- memset((void*) &threadStorageCache, 0,
- sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);
-
- /*
- * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread
- * storage subsystem gets reinitialized
- */
-
- nextThreadStorageKey = STORAGE_INVALID_KEY;
-
- Tcl_MutexUnlock(&threadStorageLock);
+ TclpThreadDeleteKey(tsdMaster.key);
+ tsdMaster.key = NULL;
}
-#else /* !defined(TCL_THREADS) */
-
+#else /* !TCL_THREADS */
/*
* Stub functions for non-threaded builds
*/
@@ -577,7 +354,7 @@ TclInitThreadStorage(void)
}
void
-TclpFinalizeThreadDataThread(void)
+TclFinalizeThreadDataThread(void)
{
}
@@ -585,8 +362,7 @@ void
TclFinalizeThreadStorage(void)
{
}
-
-#endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */
+#endif /* TCL_THREADS */
/*
* Local Variables:
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 960c7dc..71d5a66 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -7,15 +7,17 @@
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-extern int Tcltest_Init(Tcl_Interp *interp);
-
#ifdef TCL_THREADS
/*
* Each thread has an single instance of the following structure. There is one
@@ -29,11 +31,13 @@ extern int Tcltest_Init(Tcl_Interp *interp);
*/
typedef struct ThreadSpecificData {
- Tcl_ThreadId threadId; /* Tcl ID for this thread */
- Tcl_Interp *interp; /* Main interpreter for this thread */
- int flags; /* See the TP_ defines below... */
- struct ThreadSpecificData *nextPtr; /* List for "thread names" */
- struct ThreadSpecificData *prevPtr; /* List for "thread names" */
+ Tcl_ThreadId threadId; /* Tcl ID for this thread */
+ Tcl_Interp *interp; /* Main interpreter for this thread */
+ int flags; /* See the TP_ defines below... */
+ struct ThreadSpecificData *nextPtr;
+ /* List for "thread names" */
+ struct ThreadSpecificData *prevPtr;
+ /* List for "thread names" */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -42,22 +46,23 @@ static Tcl_ThreadDataKey dataKey;
* protected by threadMutex.
*/
-static struct ThreadSpecificData *threadList;
+static ThreadSpecificData *threadList;
/*
* The following bit-values are legal for the "flags" field of the
* ThreadSpecificData structure.
*/
-#define TP_Dying 0x001 /* This thread is being cancelled */
+
+#define TP_Dying 0x001 /* This thread is being canceled */
/*
* An instance of the following structure contains all information that is
* passed into a new thread when the thread is created using either the
- * "thread create" Tcl command or the TclCreateThread() C function.
+ * "thread create" Tcl command or the ThreadCreate() C function.
*/
typedef struct ThreadCtrl {
- char *script; /* The Tcl command this thread should
+ const char *script; /* The Tcl command this thread should
* execute */
int flags; /* Initial value of the "flags" field in the
* ThreadSpecificData structure for the new
@@ -103,6 +108,7 @@ static ThreadEventResult *resultList;
* This is for simple error handling when a thread script exits badly.
*/
+static Tcl_ThreadId mainThreadId;
static Tcl_ThreadId errorThreadId;
static char *errorProcString;
@@ -113,23 +119,18 @@ static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-EXTERN int TclThread_Init(Tcl_Interp *interp);
-EXTERN int Tcl_ThreadObjCmd(ClientData clientData,
+static int ThreadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-EXTERN int TclCreateThread(Tcl_Interp *interp, char *script,
+static int ThreadCreate(Tcl_Interp *interp, const char *script,
int joinable);
-EXTERN int TclThreadList(Tcl_Interp *interp);
-EXTERN int TclThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
- char *script, int wait);
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
+static int ThreadList(Tcl_Interp *interp);
+static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
+ const char *script, int wait);
+static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
+ const char *result, int flags);
-Tcl_ThreadCreateType NewTestThread(ClientData clientData);
+static Tcl_ThreadCreateType NewTestThread(ClientData clientData);
static void ListRemove(ThreadSpecificData *tsdPtr);
static void ListUpdateInner(ThreadSpecificData *tsdPtr);
static int ThreadEventProc(Tcl_Event *evPtr, int mask);
@@ -138,6 +139,7 @@ static void ThreadFreeProc(ClientData clientData);
static int ThreadDeleteEvent(Tcl_Event *eventPtr,
ClientData clientData);
static void ThreadExitProc(ClientData clientData);
+extern int Tcltest_Init(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -147,7 +149,7 @@ static void ThreadExitProc(ClientData clientData);
* Initialize the test thread command.
*
* Results:
- * TCL_OK if the package was properly initialized.
+ * TCL_OK if the package was properly initialized.
*
* Side effects:
* Add the "testthread" command to the interp.
@@ -159,9 +161,17 @@ int
TclThread_Init(
Tcl_Interp *interp) /* The current Tcl interpreter */
{
+ /*
+ * If the main thread Id has not been set, do it now.
+ */
- Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd,
- (ClientData) NULL, NULL);
+ Tcl_MutexLock(&threadMutex);
+ if (mainThreadId == 0) {
+ mainThreadId = Tcl_GetCurrentThread();
+ }
+ Tcl_MutexUnlock(&threadMutex);
+
+ Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
return TCL_OK;
}
@@ -169,15 +179,17 @@ TclThread_Init(
/*
*----------------------------------------------------------------------
*
- * Tcl_ThreadObjCmd --
+ * ThreadObjCmd --
*
* This procedure is invoked to process the "testthread" Tcl command. See
* the user documentation for details on what it does.
*
+ * thread cancel ?-unwind? id ?result?
* thread create ?-joinable? ?script?
- * thread send id ?-async? script
+ * thread send ?-async? id script
+ * thread event
* thread exit
- * thread info id
+ * thread id ?-main?
* thread names
* thread wait
* thread errorproc proc
@@ -193,8 +205,8 @@ TclThread_Init(
*/
/* ARGSUSED */
-int
-Tcl_ThreadObjCmd(
+static int
+ThreadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -202,17 +214,19 @@ Tcl_ThreadObjCmd(
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
- static const char *threadOptions[] = {
- "create", "exit", "id", "join", "names",
- "send", "wait", "errorproc", NULL
+ static const char *const threadOptions[] = {
+ "cancel", "create", "event", "exit", "id",
+ "join", "names", "send", "wait", "errorproc",
+ NULL
};
enum options {
- THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
- THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
+ THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
+ THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
+ THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
@@ -233,8 +247,36 @@ Tcl_ThreadObjCmd(
}
switch ((enum options)option) {
+ case THREAD_CANCEL: {
+ long id;
+ const char *result;
+ int flags, arg;
+
+ if ((objc < 3) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
+ return TCL_ERROR;
+ }
+ flags = 0;
+ arg = 2;
+ if ((objc == 4) || (objc == 5)) {
+ if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
+ flags = TCL_CANCEL_UNWIND;
+ arg++;
+ }
+ }
+ if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
+ if (arg < objc) {
+ result = Tcl_GetString(objv[arg]);
+ } else {
+ result = NULL;
+ }
+ return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
+ }
case THREAD_CREATE: {
- char *script;
+ const char *script;
int joinable, len;
if (objc == 2) {
@@ -252,9 +294,8 @@ Tcl_ThreadObjCmd(
script = Tcl_GetStringFromObj(objv[2], &len);
- if ((len > 1) &&
- (script [0] == '-') && (script [1] == 'j') &&
- (0 == strncmp (script, "-joinable", (size_t) len))) {
+ if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
+ (0 == strncmp(script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
@@ -270,17 +311,14 @@ Tcl_ThreadObjCmd(
*/
script = Tcl_GetStringFromObj(objv[2], &len);
-
- joinable = ((len > 1) &&
- (script [0] == '-') && (script [1] == 'j') &&
- (0 == strncmp(script, "-joinable", (size_t) len)));
-
+ joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
+ && (0 == strncmp(script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
- return TclCreateThread(interp, script, joinable);
+ return ThreadCreate(interp, script, joinable);
}
case THREAD_EXIT:
if (objc > 2) {
@@ -291,8 +329,24 @@ Tcl_ThreadObjCmd(
Tcl_ExitThread(0);
return TCL_OK;
case THREAD_ID:
- if (objc == 2) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
+ if (objc == 2 || objc == 3) {
+ Tcl_Obj *idObj;
+
+ /*
+ * Check if they want the main thread id or the current thread id.
+ */
+
+ if (objc == 2) {
+ idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
+ } else if (objc == 3
+ && strcmp("-main", Tcl_GetString(objv[2])) == 0) {
+ Tcl_MutexLock(&threadMutex);
+ idObj = Tcl_NewLongObj((long)(size_t)mainThreadId);
+ Tcl_MutexUnlock(&threadMutex);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
@@ -312,13 +366,13 @@ Tcl_ThreadObjCmd(
return TCL_ERROR;
}
- result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
+ result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
if (result == TCL_OK) {
- Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
- char buf [20];
+ char buf[20];
- sprintf(buf, "%ld", id);
+ TclFormatInt(buf, id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
@@ -328,10 +382,10 @@ Tcl_ThreadObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- return TclThreadList(interp);
+ return ThreadList(interp);
case THREAD_SEND: {
long id;
- char *script;
+ const char *script;
int wait, arg;
if ((objc != 4) && (objc != 5)) {
@@ -354,14 +408,23 @@ Tcl_ThreadObjCmd(
}
arg++;
script = Tcl_GetString(objv[arg]);
- return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
+ return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
+ }
+ case THREAD_EVENT: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
+ return TCL_OK;
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
- char *proc;
+ const char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
@@ -373,15 +436,41 @@ Tcl_ThreadObjCmd(
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
- errorProcString = ckalloc(strlen(proc)+1);
+ errorProcString = ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ return TCL_ERROR;
+ }
while (1) {
+ /*
+ * If the script has been unwound, bail out immediately. This does
+ * not follow the recommended guidelines for how extensions should
+ * handle the script cancellation functionality because this is
+ * not a "normal" extension. Most extensions do not have a command
+ * that simply enters an infinite Tcl event loop. Normal
+ * extensions should not specify the TCL_CANCEL_UNWIND when
+ * calling Tcl_Canceled to check if the command has been canceled.
+ */
+
+ if (Tcl_Canceled(interp,
+ TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
+ break;
+ }
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
+
+ /*
+ * If we get to this point, we have been canceled by another thread,
+ * which is considered to be an "error".
+ */
+
+ ThreadErrorProc(interp);
+ return TCL_OK;
}
return TCL_OK;
}
@@ -389,7 +478,7 @@ Tcl_ThreadObjCmd(
/*
*----------------------------------------------------------------------
*
- * TclCreateThread --
+ * ThreadCreate --
*
* This procedure is invoked to create a thread containing an interp to
* run a script. This returns after the thread has started executing.
@@ -404,10 +493,10 @@ Tcl_ThreadObjCmd(
*/
/* ARGSUSED */
-int
-TclCreateThread(
+static int
+ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
- char *script, /* Script to execute */
+ const char *script, /* Script to execute */
int joinable) /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
@@ -423,8 +512,8 @@ TclCreateThread(
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
- Tcl_AppendResult(interp, "can't create a new thread", NULL);
- ckfree((char *) ctrl.script);
+ Tcl_AppendResult(interp, "can't create a new thread", NULL);
+ ckfree(ctrl.script);
return TCL_ERROR;
}
@@ -435,7 +524,7 @@ TclCreateThread(
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id));
return TCL_OK;
}
@@ -471,18 +560,20 @@ Tcl_ThreadCreateType
NewTestThread(
ClientData clientData)
{
- ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
+ ThreadCtrl *ctrlPtr = clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
/*
- * Initialize the interpreter. This should be more general.
+ * Initialize the interpreter. This should be more general.
*/
tsdPtr->interp = Tcl_CreateInterp();
result = Tcl_Init(tsdPtr->interp);
- result = TclThread_Init(tsdPtr->interp);
+ if (result != TCL_OK) {
+ ThreadErrorProc(tsdPtr->interp);
+ }
/*
* This is part of the test facility. Initialize _ALL_ test commands for
@@ -490,6 +581,9 @@ NewTestThread(
*/
result = Tcltest_Init(tsdPtr->interp);
+ if (result != TCL_OK) {
+ ThreadErrorProc(tsdPtr->interp);
+ }
/*
* Update the list of threads.
@@ -503,10 +597,10 @@ NewTestThread(
* eval'ing, for the case that we exit during evaluation
*/
- threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
+ threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
- Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
+ Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
/*
* Notify the parent we are alive.
@@ -519,7 +613,7 @@ NewTestThread(
* Run the script.
*/
- Tcl_Preserve((ClientData) tsdPtr->interp);
+ Tcl_Preserve(tsdPtr->interp);
result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
@@ -530,7 +624,7 @@ NewTestThread(
*/
ListRemove(tsdPtr);
- Tcl_Release((ClientData) tsdPtr->interp);
+ Tcl_Release(tsdPtr->interp);
Tcl_DeleteInterp(tsdPtr->interp);
Tcl_ExitThread(result);
@@ -561,7 +655,8 @@ ThreadErrorProc(
const char *errorInfo, *argv[3];
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
+
+ TclFormatInt(buf, (size_t) Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
@@ -576,7 +671,7 @@ ThreadErrorProc(
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
- TclThreadSend(interp, errorThreadId, script, 0);
+ ThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
@@ -655,7 +750,7 @@ ListRemove(
/*
*------------------------------------------------------------------------
*
- * TclThreadList --
+ * ThreadList --
*
* Return a list of threads running Tcl interpreters.
*
@@ -667,8 +762,8 @@ ListRemove(
*
*------------------------------------------------------------------------
*/
-int
-TclThreadList(
+static int
+ThreadList(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr;
@@ -678,7 +773,7 @@ TclThreadList(
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewLongObj((long) tsdPtr->threadId));
+ Tcl_NewLongObj((long)(size_t)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
@@ -688,7 +783,7 @@ TclThreadList(
/*
*------------------------------------------------------------------------
*
- * TclThreadSend --
+ * ThreadSend --
*
* Send a script to another thread.
*
@@ -701,11 +796,11 @@ TclThreadList(
*------------------------------------------------------------------------
*/
-int
-TclThreadSend(
+static int
+ThreadSend(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId id, /* Thread Id of other interpreter. */
- char *script, /* The script to evaluate. */
+ const char *script, /* The script to evaluate. */
int wait) /* If 1, we block for the result. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -738,7 +833,7 @@ TclThreadSend(
*/
if (threadId == Tcl_GetCurrentThread()) {
- Tcl_MutexUnlock(&threadMutex);
+ Tcl_MutexUnlock(&threadMutex);
return Tcl_GlobalEval(interp, script);
}
@@ -746,13 +841,13 @@ TclThreadSend(
* Create the event for its event queue.
*/
- threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
+ threadEventPtr = ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
- resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
+ resultPtr = ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
@@ -785,7 +880,7 @@ TclThreadSend(
*/
threadEventPtr->event.proc = ThreadEventProc;
- Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
+ Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
TCL_QUEUE_TAIL);
Tcl_ThreadAlert(threadId);
@@ -800,7 +895,7 @@ TclThreadSend(
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
- Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
+ Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
@@ -835,7 +930,7 @@ TclThreadSend(
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
- ckfree((char *) resultPtr);
+ ckfree(resultPtr);
return code;
}
@@ -843,6 +938,61 @@ TclThreadSend(
/*
*------------------------------------------------------------------------
*
+ * ThreadCancel --
+ *
+ * Cancels a script in another thread.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+
+static int
+ThreadCancel(
+ Tcl_Interp *interp, /* The current interpreter. */
+ Tcl_ThreadId id, /* Thread Id of other interpreter. */
+ const char *result, /* The result or NULL for default. */
+ int flags) /* Flags for Tcl_CancelEval. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int found;
+ Tcl_ThreadId threadId = (Tcl_ThreadId) id;
+
+ /*
+ * Verify the thread exists.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ found = 0;
+ for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
+ if (tsdPtr->threadId == threadId) {
+ found = 1;
+ break;
+ }
+ }
+ if (!found) {
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_AppendResult(interp, "invalid thread id", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Since Tcl_CancelEval can be safely called from any thread,
+ * we do it now.
+ */
+
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_ResetResult(interp);
+ return Tcl_CancelEval(tsdPtr->interp, Tcl_NewStringObj(result, -1), 0, flags);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
* ThreadEventProc --
*
* Handle the event in the target thread.
@@ -862,7 +1012,7 @@ ThreadEventProc(
int mask)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
+ ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
@@ -874,13 +1024,11 @@ ThreadEventProc(
errorCode = "THREAD";
errorInfo = "";
} else {
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(interp);
Tcl_ResetResult(interp);
- Tcl_CreateThreadExitHandler(ThreadFreeProc,
- (ClientData) threadEventPtr->script);
+ Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
- Tcl_DeleteThreadExitHandler(ThreadFreeProc,
- (ClientData) threadEventPtr->script);
+ Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
@@ -907,7 +1055,7 @@ ThreadEventProc(
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
- Tcl_Release((ClientData) interp);
+ Tcl_Release(interp);
}
return 1;
}
@@ -935,7 +1083,7 @@ ThreadFreeProc(
ClientData clientData)
{
if (clientData) {
- ckfree((char *) clientData);
+ ckfree(clientData);
}
}
@@ -963,7 +1111,7 @@ ThreadDeleteEvent(
ClientData clientData) /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
- ckfree((char *) ((ThreadEvent *) eventPtr)->script);
+ ckfree(((ThreadEvent *) eventPtr)->script);
return 1;
}
@@ -997,17 +1145,17 @@ static void
ThreadExitProc(
ClientData clientData)
{
- char *threadEvalScript = (char *) clientData;
+ char *threadEvalScript = clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
Tcl_MutexLock(&threadMutex);
if (threadEvalScript) {
- ckfree((char *) threadEvalScript);
+ ckfree(threadEvalScript);
threadEvalScript = NULL;
}
- Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
+ Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
@@ -1027,7 +1175,7 @@ ThreadExitProc(
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
- ckfree((char *) resultPtr);
+ ckfree(resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller. The result
@@ -1035,9 +1183,9 @@ ThreadExitProc(
* going to call free on it.
*/
- char *msg = "target thread died";
+ const char *msg = "target thread died";
- resultPtr->result = ckalloc(strlen(msg)+1);
+ resultPtr->result = ckalloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 33838ec..6682d21 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -72,7 +72,7 @@ typedef struct AfterAssocData {
*/
typedef struct IdleHandler {
- Tcl_IdleProc (*proc); /* Function to call. */
+ Tcl_IdleProc *proc; /* Function to call. */
ClientData clientData; /* Value to pass to proc. */
int generation; /* Used to distinguish older handlers from
* recently-created ones. */
@@ -127,6 +127,25 @@ static Tcl_ThreadDataKey dataKey;
(1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
((long)(t1).usec - (long)(t2).usec)/1000)
+#define TCL_TIME_DIFF_MS_CEILING(t1, t2) \
+ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
+ ((long)(t1).usec - (long)(t2).usec + 999)/1000)
+
+/*
+ * Sleeps under that number of milliseconds don't get double-checked
+ * and are done in exactly one Tcl_Sleep(). This to limit gettimeofday()s.
+ */
+
+#define SLEEP_OFFLOAD_GETTIMEOFDAY 20
+
+/*
+ * The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay.
+ * This is used to limit the maximum lag between interp limit and script
+ * cancellation checks.
+ */
+
+#define TCL_TIME_MAXIMUM_SLICE 500
+
/*
* Prototypes for functions referenced only in this file:
*/
@@ -205,7 +224,7 @@ TimerExitProc(
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
- ckfree((char *) timerHandlerPtr);
+ ckfree(timerHandlerPtr);
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
}
}
@@ -281,13 +300,13 @@ TclCreateAbsoluteTimerHandler(
ThreadSpecificData *tsdPtr;
tsdPtr = InitTimer();
- timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
+ timerHandlerPtr = ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
*/
- memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time));
+ memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
tsdPtr->lastTimerId++;
@@ -357,7 +376,7 @@ Tcl_DeleteTimerHandler(
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
- ckfree((char *) timerHandlerPtr);
+ ckfree(timerHandlerPtr);
return;
}
}
@@ -396,7 +415,6 @@ TimerSetupProc(
blockTime.sec = 0;
blockTime.usec = 0;
-
} else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
/*
* Compute the timeout for the next timer on the list.
@@ -473,7 +491,7 @@ TimerCheckProc(
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
- timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event));
+ timerEvPtr = ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
@@ -574,9 +592,9 @@ TimerHandlerEventProc(
* potential reentrancy problems.
*/
- (*nextPtrPtr) = timerHandlerPtr->nextPtr;
- (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
- ckfree((char *) timerHandlerPtr);
+ *nextPtrPtr = timerHandlerPtr->nextPtr;
+ timerHandlerPtr->proc(timerHandlerPtr->clientData);
+ ckfree(timerHandlerPtr);
}
TimerSetupProc(NULL, TCL_TIMER_EVENTS);
return 1;
@@ -610,7 +628,7 @@ Tcl_DoWhenIdle(
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
- idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
+ idlePtr = ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
@@ -659,7 +677,7 @@ Tcl_CancelIdleCall(
while ((idlePtr->proc == proc)
&& (idlePtr->clientData == clientData)) {
nextPtr = idlePtr->nextPtr;
- ckfree((char *) idlePtr);
+ ckfree(idlePtr);
idlePtr = nextPtr;
if (prevPtr == NULL) {
tsdPtr->idleList = idlePtr;
@@ -733,8 +751,8 @@ TclServiceIdle(void)
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
- (*idlePtr->proc)(idlePtr->clientData);
- ckfree((char *) idlePtr);
+ idlePtr->proc(idlePtr->clientData);
+ ckfree(idlePtr);
}
if (tsdPtr->idleList) {
blockTime.sec = 0;
@@ -767,23 +785,23 @@ Tcl_AfterObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_WideInt ms; /* Number of milliseconds to wait */
+ Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
char buf[16 + TCL_INTEGER_SPACE];
- static CONST char *afterSubCmds[] = {
+ static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
@@ -794,11 +812,10 @@ Tcl_AfterObjCmd(
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
- assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
+ assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
- Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
- (ClientData) assocPtr);
+ Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
@@ -807,22 +824,24 @@ Tcl_AfterObjCmd(
if (objv[1]->typePtr == &tclIntType
#ifndef NO_WIDE_TYPE
- || objv[1]->typePtr == &tclWideIntType
+ || objv[1]->typePtr == &tclWideIntType
#endif
- || objv[1]->typePtr == &tclBignumType
- || ( Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
- &index) != TCL_OK )) {
+ || objv[1]->typePtr == &tclBignumType
+ || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
+ &index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
- Tcl_AppendResult(interp, "bad argument \"",
- Tcl_GetString(objv[1]),
- "\": must be cancel, idle, info, or an integer",
- NULL);
+ const char *arg = Tcl_GetString(objv[1]);
+
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": must be cancel, idle, info, or an integer", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
+ arg, NULL);
return TCL_ERROR;
}
}
- /*
+ /*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
*/
@@ -835,12 +854,12 @@ Tcl_AfterObjCmd(
if (objc == 2) {
return AfterDelay(interp, ms);
}
- afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
- afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
+ afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
@@ -863,8 +882,8 @@ Tcl_AfterObjCmd(
wakeup.sec++;
wakeup.usec -= 1000000;
}
- afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, AfterProc,
- (ClientData) afterPtr);
+ afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
+ AfterProc, afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
@@ -872,7 +891,7 @@ Tcl_AfterObjCmd(
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
- char *command, *tempCommand;
+ const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
@@ -890,8 +909,7 @@ Tcl_AfterObjCmd(
tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
- && (memcmp((void*) command, (void*) tempCommand,
- (unsigned) length) == 0)) {
+ && !memcmp(command, tempCommand, (unsigned) length)) {
break;
}
}
@@ -905,7 +923,7 @@ Tcl_AfterObjCmd(
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ Tcl_CancelIdleCall(AfterProc, afterPtr);
}
FreeAfterPtr(afterPtr);
}
@@ -913,10 +931,10 @@ Tcl_AfterObjCmd(
}
case AFTER_IDLE:
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
+ Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
- afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
@@ -929,12 +947,10 @@ Tcl_AfterObjCmd(
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
- Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
+ Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
- case AFTER_INFO: {
- Tcl_Obj *resultListPtr;
-
+ case AFTER_INFO:
if (objc == 2) {
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
@@ -951,17 +967,22 @@ Tcl_AfterObjCmd(
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]),
- "\" doesn't exist", NULL);
+ const char *eventStr = TclGetString(objv[2]);
+
+ Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
- }
- resultListPtr = Tcl_NewObj();
- Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
- Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (afterPtr->token == NULL) ? "idle" : "timer", -1));
- Tcl_SetObjResult(interp, resultListPtr);
+ } else {
+ Tcl_Obj *resultListPtr = Tcl_NewObj();
+
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ afterPtr->commandPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (afterPtr->token == NULL) ? "idle" : "timer", -1));
+ Tcl_SetObjResult(interp, resultListPtr);
+ }
break;
- }
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
@@ -978,7 +999,7 @@ Tcl_AfterObjCmd(
*
* Results:
* Standard Tcl result code (with error set if an error occurred due to a
- * time limit being exceeded).
+ * time limit being exceeded or being canceled).
*
* Side effects:
* May adjust the time limit granularity marker.
@@ -996,7 +1017,8 @@ AfterDelay(
Tcl_Time endTime, now;
Tcl_WideInt diff;
- Tcl_GetTime(&endTime);
+ Tcl_GetTime(&now);
+ endTime = now;
endTime.sec += (long)(ms/1000);
endTime.usec += ((int)(ms%1000))*1000;
if (endTime.usec >= 1000000) {
@@ -1005,25 +1027,37 @@ AfterDelay(
}
do {
- Tcl_GetTime(&now);
+ if (Tcl_AsyncReady()) {
+ if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (iPtr->limit.timeEvent != NULL
- && TCL_TIME_BEFORE(iPtr->limit.time, now)) {
+ && TCL_TIME_BEFORE(iPtr->limit.time, now)) {
iPtr->limit.granularityTicker = 0;
if (Tcl_LimitCheck(interp) != TCL_OK) {
return TCL_ERROR;
}
}
if (iPtr->limit.timeEvent == NULL
- || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
- diff = TCL_TIME_DIFF_MS(endTime, now);
+ || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
+ diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
#ifndef TCL_WIDE_INT_IS_LONG
if (diff > LONG_MAX) {
diff = LONG_MAX;
}
#endif
- if (diff > 0) {
- Tcl_Sleep((long)diff);
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
}
+ if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1;
+ if (diff > 0) {
+ Tcl_Sleep((long) diff);
+ if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break;
+ } else break;
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
#ifndef TCL_WIDE_INT_IS_LONG
@@ -1031,13 +1065,25 @@ AfterDelay(
diff = LONG_MAX;
}
#endif
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
+ }
if (diff > 0) {
- Tcl_Sleep((long)diff);
+ Tcl_Sleep((long) diff);
+ }
+ if (Tcl_AsyncReady()) {
+ if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
}
if (Tcl_LimitCheck(interp) != TCL_OK) {
return TCL_ERROR;
}
}
+ Tcl_GetTime(&now);
} while (TCL_TIME_BEFORE(now, endTime));
return TCL_OK;
}
@@ -1067,7 +1113,7 @@ GetAfterEvent(
* this interpreter. */
Tcl_Obj *commandPtr)
{
- char *cmdString; /* Textual identifier for after event, such as
+ const char *cmdString; /* Textual identifier for after event, such as
* "after#6". */
AfterInfo *afterPtr;
int id;
@@ -1114,7 +1160,7 @@ static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
- AfterInfo *afterPtr = (AfterInfo *) clientData;
+ AfterInfo *afterPtr = clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
@@ -1141,20 +1187,20 @@ AfterProc(
*/
interp = assocPtr->interp;
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(interp);
result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
- TclBackgroundException(interp, result);
+ Tcl_BackgroundException(interp, result);
}
- Tcl_Release((ClientData) interp);
+ Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree((char *) afterPtr);
+ ckfree(afterPtr);
}
/*
@@ -1192,7 +1238,7 @@ FreeAfterPtr(
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree((char *) afterPtr);
+ ckfree(afterPtr);
}
/*
@@ -1219,7 +1265,7 @@ AfterCleanupProc(
* interpreter. */
Tcl_Interp *interp) /* Interpreter that is being deleted. */
{
- AfterAssocData *assocPtr = (AfterAssocData *) clientData;
+ AfterAssocData *assocPtr = clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
@@ -1228,12 +1274,12 @@ AfterCleanupProc(
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ Tcl_CancelIdleCall(AfterProc, afterPtr);
}
Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree((char *) afterPtr);
+ ckfree(afterPtr);
}
- ckfree((char *) assocPtr);
+ ckfree(assocPtr);
}
/*
@@ -1241,5 +1287,7 @@ AfterCleanupProc(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index ca883f6..5bf338e 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -19,196 +19,197 @@ library tcl
interface tclTomMath
# hooks {tclTomMathInt}
+scspec EXTERN
# Declare each of the functions in the Tcl tommath interface
-declare 0 generic {
+declare 0 {
int TclBN_epoch(void)
}
-declare 1 generic {
+declare 1 {
int TclBN_revision(void)
}
-declare 2 generic {
+declare 2 {
int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c)
}
-declare 3 generic {
+declare 3 {
int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c)
}
-declare 4 generic {
+declare 4 {
int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c)
}
-declare 5 generic {
+declare 5 {
void TclBN_mp_clamp(mp_int *a)
}
-declare 6 generic {
+declare 6 {
void TclBN_mp_clear(mp_int *a)
}
-declare 7 generic {
+declare 7 {
void TclBN_mp_clear_multi(mp_int *a, ...)
}
-declare 8 generic {
- int TclBN_mp_cmp(mp_int *a, mp_int *b)
+declare 8 {
+ int TclBN_mp_cmp(const mp_int *a, const mp_int *b)
}
-declare 9 generic {
- int TclBN_mp_cmp_d(mp_int *a, mp_digit b)
+declare 9 {
+ int TclBN_mp_cmp_d(const mp_int *a, mp_digit b)
}
-declare 10 generic {
- int TclBN_mp_cmp_mag(mp_int *a, mp_int *b)
+declare 10 {
+ int TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
}
-declare 11 generic {
- int TclBN_mp_copy(mp_int *a, mp_int *b)
+declare 11 {
+ int TclBN_mp_copy(const mp_int *a, mp_int *b)
}
-declare 12 generic {
- int TclBN_mp_count_bits(mp_int *a)
+declare 12 {
+ int TclBN_mp_count_bits(const mp_int *a)
}
-declare 13 generic {
+declare 13 {
int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r)
}
-declare 14 generic {
+declare 14 {
int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, mp_digit *r)
}
-declare 15 generic {
+declare 15 {
int TclBN_mp_div_2(mp_int *a, mp_int *q)
}
-declare 16 generic {
- int TclBN_mp_div_2d(mp_int *a, int b, mp_int *q, mp_int *r)
+declare 16 {
+ int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
-declare 17 generic {
+declare 17 {
int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r)
}
-declare 18 generic {
+declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
-declare 19 generic {
+declare 19 {
int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c)
}
-declare 20 generic {
+declare 20 {
int TclBN_mp_grow(mp_int *a, int size)
}
-declare 21 generic {
+declare 21 {
int TclBN_mp_init(mp_int *a)
}
-declare 22 generic {
+declare 22 {
int TclBN_mp_init_copy(mp_int *a, mp_int *b)
}
-declare 23 generic {
+declare 23 {
int TclBN_mp_init_multi(mp_int *a, ...)
}
-declare 24 generic {
+declare 24 {
int TclBN_mp_init_set(mp_int *a, mp_digit b)
}
-declare 25 generic {
+declare 25 {
int TclBN_mp_init_size(mp_int *a, int size)
}
-declare 26 generic {
+declare 26 {
int TclBN_mp_lshd(mp_int *a, int shift)
}
-declare 27 generic {
+declare 27 {
int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r)
}
-declare 28 generic {
- int TclBN_mp_mod_2d(mp_int *a, int b, mp_int *r)
+declare 28 {
+ int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
}
-declare 29 generic {
+declare 29 {
int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p)
}
-declare 30 generic {
+declare 30 {
int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p)
}
-declare 31 generic {
+declare 31 {
int TclBN_mp_mul_2(mp_int *a, mp_int *p)
}
-declare 32 generic {
- int TclBN_mp_mul_2d(mp_int *a, int d, mp_int *p)
+declare 32 {
+ int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
}
-declare 33 generic {
- int TclBN_mp_neg(mp_int *a, mp_int *b)
+declare 33 {
+ int TclBN_mp_neg(const mp_int *a, mp_int *b)
}
-declare 34 generic {
+declare 34 {
int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c)
}
-declare 35 generic {
+declare 35 {
int TclBN_mp_radix_size(mp_int *a, int radix, int *size)
}
-declare 36 generic {
+declare 36 {
int TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
}
-declare 37 generic {
+declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
-declare 38 generic {
+declare 38 {
int TclBN_mp_shrink(mp_int *a)
}
-declare 39 generic {
+declare 39 {
void TclBN_mp_set(mp_int *a, mp_digit b)
}
-declare 40 generic {
+declare 40 {
int TclBN_mp_sqr(mp_int *a, mp_int *b)
}
-declare 41 generic {
+declare 41 {
int TclBN_mp_sqrt(mp_int *a, mp_int *b)
}
-declare 42 generic {
+declare 42 {
int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c)
}
-declare 43 generic {
+declare 43 {
int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c)
}
-declare 44 generic {
+declare 44 {
int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b)
}
-declare 45 generic {
+declare 45 {
int TclBN_mp_to_unsigned_bin_n(mp_int *a, unsigned char *b,
unsigned long *outlen)
}
-declare 46 generic {
+declare 46 {
int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, int maxlen)
}
-declare 47 generic {
+declare 47 {
int TclBN_mp_unsigned_bin_size(mp_int *a)
}
-declare 48 generic {
+declare 48 {
int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c)
}
-declare 49 generic {
+declare 49 {
void TclBN_mp_zero(mp_int *a)
}
# internal routines to libtommath - should not be called but must be
# exported to accommodate the "tommath" extension
-declare 50 generic {
+declare 50 {
void TclBN_reverse(unsigned char *s, int len)
}
-declare 51 generic {
+declare 51 {
int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs)
}
-declare 52 generic {
+declare 52 {
int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b)
}
-declare 53 generic {
+declare 53 {
int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c)
}
-declare 54 generic {
+declare 54 {
int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b)
}
-declare 55 generic {
+declare 55 {
int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c)
}
-declare 56 generic {
+declare 56 {
int TclBN_mp_toom_sqr(mp_int *a, mp_int *b)
}
-declare 57 generic {
+declare 57 {
int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c)
}
-declare 58 generic {
+declare 58 {
int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs)
}
-declare 59 generic {
+declare 59 {
int TclBN_s_mp_sqr(mp_int *a, mp_int *b)
}
-declare 60 generic {
+declare 60 {
int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c)
}
declare 61 {
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index 550dafa..eca435f 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -15,23 +15,20 @@
#ifndef BN_H_
#define BN_H_
-#include <tclTomMathDecls.h>
+#include "tclInt.h"
+#include "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include <ctype.h>
-#include <limits.h>
+
#ifndef MIN
- #define MIN(x,y) ((x)<(y)?(x):(y))
+# define MIN(x,y) ((x)<(y)?(x):(y))
#endif
#ifndef MAX
- #define MAX(x,y) ((x)>(y)?(x):(y))
+# define MAX(x,y) ((x)>(y)?(x):(y))
#endif
#ifdef __cplusplus
@@ -50,9 +47,9 @@ extern "C" {
/* detect 64-bit mode if possible */
#if defined(NEVER) /* 128-bit ints fail in too many places */
- #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
- #define MP_64BIT
- #endif
+# if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
+# define MP_64BIT
+# endif
#endif
/* some default configurations.
@@ -88,19 +85,19 @@ extern "C" {
#endif
typedef unsigned long mp_word __attribute__ ((mode(TI)));
- #define DIGIT_BIT 60
+# define DIGIT_BIT 60
#else
/* this is the default case, 28-bit digits */
/* this is to make porting into LibTomCrypt easier :-) */
#ifndef CRYPT
- #if defined(_MSC_VER) || defined(__BORLANDC__)
+# if defined(_MSC_VER) || defined(__BORLANDC__)
typedef unsigned __int64 ulong64;
typedef signed __int64 long64;
- #else
+# else
typedef unsigned long long ulong64;
typedef signed long long long64;
- #endif
+# endif
#endif
#ifndef MP_DIGIT_DECLARED
@@ -111,11 +108,11 @@ extern "C" {
#ifdef MP_31BIT
/* this is an extension that uses 31-bit digits */
- #define DIGIT_BIT 31
+# define DIGIT_BIT 31
#else
/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
- #define DIGIT_BIT 28
- #define MP_28BIT
+# define DIGIT_BIT 28
+# define MP_28BIT
#endif
#endif
@@ -123,25 +120,25 @@ extern "C" {
#if 0 /* these are macros in tclTomMathDecls.h */
#ifndef CRYPT
/* default to libc stuff */
- #ifndef XMALLOC
- #define XMALLOC malloc
- #define XFREE free
- #define XREALLOC realloc
- #define XCALLOC calloc
- #else
+# ifndef XMALLOC
+# define XMALLOC malloc
+# define XFREE free
+# define XREALLOC realloc
+# define XCALLOC calloc
+# else
/* prototypes for our heap functions */
extern void *XMALLOC(size_t n);
extern void *XREALLOC(void *p, size_t n);
extern void *XCALLOC(size_t n, size_t s);
extern void XFREE(void *p);
- #endif
+# endif
#endif
#endif
/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
#ifndef DIGIT_BIT
- #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */
+# define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */
#endif
#define MP_DIGIT_BIT DIGIT_BIT
@@ -184,11 +181,11 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF,
/* default precision */
#ifndef MP_PREC
- #ifndef MP_LOW_MEM
- #define MP_PREC 32 /* default digits of precision */
- #else
- #define MP_PREC 8 /* default digits of precision */
- #endif
+# ifndef MP_LOW_MEM
+# define MP_PREC 32 /* default digits of precision */
+# else
+# define MP_PREC 8 /* default digits of precision */
+# endif
#endif
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
@@ -293,7 +290,7 @@ int mp_init_set_int (mp_int * a, unsigned long b);
/* copy, b = a */
/*
-int mp_copy(mp_int *a, mp_int *b);
+int mp_copy(const mp_int *a, mp_int *b);
*/
/* inits and copies, a = b */
@@ -320,7 +317,7 @@ int mp_lshd(mp_int *a, int b);
/* c = a / 2**b */
/*
-int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d);
+int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d);
*/
/* b = a/2 */
@@ -330,7 +327,7 @@ int mp_div_2(mp_int *a, mp_int *b);
/* c = a * 2**b */
/*
-int mp_mul_2d(mp_int *a, int b, mp_int *c);
+int mp_mul_2d(const mp_int *a, int b, mp_int *c);
*/
/* b = a*2 */
@@ -340,7 +337,7 @@ int mp_mul_2(mp_int *a, mp_int *b);
/* c = a mod 2**d */
/*
-int mp_mod_2d(mp_int *a, int b, mp_int *c);
+int mp_mod_2d(const mp_int *a, int b, mp_int *c);
*/
/* computes a = 2**b */
@@ -380,7 +377,7 @@ int mp_and(mp_int *a, mp_int *b, mp_int *c);
/* b = -a */
/*
-int mp_neg(mp_int *a, mp_int *b);
+int mp_neg(const mp_int *a, mp_int *b);
*/
/* b = |a| */
@@ -390,12 +387,12 @@ int mp_abs(mp_int *a, mp_int *b);
/* compare a to b */
/*
-int mp_cmp(mp_int *a, mp_int *b);
+int mp_cmp(const mp_int *a, const mp_int *b);
*/
/* compare |a| to |b| */
/*
-int mp_cmp_mag(mp_int *a, mp_int *b);
+int mp_cmp_mag(const mp_int *a, const mp_int *b);
*/
/* c = a + b */
@@ -432,7 +429,7 @@ int mp_mod(mp_int *a, mp_int *b, mp_int *c);
/* compare against a single digit */
/*
-int mp_cmp_d(mp_int *a, mp_digit b);
+int mp_cmp_d(const mp_int *a, mp_digit b);
*/
/* c = a + b */
@@ -620,9 +617,9 @@ int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
/* number of primes */
#ifdef MP_8BIT
- #define PRIME_SIZE 31
+# define PRIME_SIZE 31
#else
- #define PRIME_SIZE 256
+# define PRIME_SIZE 256
#endif
/* table of first PRIME_SIZE primes */
@@ -707,7 +704,7 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback
/* ---> radix conversion <--- */
/*
-int mp_count_bits(mp_int *a);
+int mp_count_bits(const mp_int *a);
*/
/*
@@ -830,7 +827,7 @@ MODULE_SCOPE const char *mp_s_rmap;
#endif
#ifdef __cplusplus
- }
+}
#endif
#endif
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index f072311..7df0d90 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -137,334 +137,145 @@
* Exported function declarations:
*/
-#ifndef TclBN_epoch_TCL_DECLARED
-#define TclBN_epoch_TCL_DECLARED
/* 0 */
EXTERN int TclBN_epoch(void);
-#endif
-#ifndef TclBN_revision_TCL_DECLARED
-#define TclBN_revision_TCL_DECLARED
/* 1 */
EXTERN int TclBN_revision(void);
-#endif
-#ifndef TclBN_mp_add_TCL_DECLARED
-#define TclBN_mp_add_TCL_DECLARED
/* 2 */
EXTERN int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_add_d_TCL_DECLARED
-#define TclBN_mp_add_d_TCL_DECLARED
/* 3 */
EXTERN int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c);
-#endif
-#ifndef TclBN_mp_and_TCL_DECLARED
-#define TclBN_mp_and_TCL_DECLARED
/* 4 */
EXTERN int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_clamp_TCL_DECLARED
-#define TclBN_mp_clamp_TCL_DECLARED
/* 5 */
EXTERN void TclBN_mp_clamp(mp_int *a);
-#endif
-#ifndef TclBN_mp_clear_TCL_DECLARED
-#define TclBN_mp_clear_TCL_DECLARED
/* 6 */
EXTERN void TclBN_mp_clear(mp_int *a);
-#endif
-#ifndef TclBN_mp_clear_multi_TCL_DECLARED
-#define TclBN_mp_clear_multi_TCL_DECLARED
/* 7 */
EXTERN void TclBN_mp_clear_multi(mp_int *a, ...);
-#endif
-#ifndef TclBN_mp_cmp_TCL_DECLARED
-#define TclBN_mp_cmp_TCL_DECLARED
/* 8 */
-EXTERN int TclBN_mp_cmp(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_cmp_d_TCL_DECLARED
-#define TclBN_mp_cmp_d_TCL_DECLARED
+EXTERN int TclBN_mp_cmp(const mp_int *a, const mp_int *b);
/* 9 */
-EXTERN int TclBN_mp_cmp_d(mp_int *a, mp_digit b);
-#endif
-#ifndef TclBN_mp_cmp_mag_TCL_DECLARED
-#define TclBN_mp_cmp_mag_TCL_DECLARED
+EXTERN int TclBN_mp_cmp_d(const mp_int *a, mp_digit b);
/* 10 */
-EXTERN int TclBN_mp_cmp_mag(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_copy_TCL_DECLARED
-#define TclBN_mp_copy_TCL_DECLARED
+EXTERN int TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b);
/* 11 */
-EXTERN int TclBN_mp_copy(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_count_bits_TCL_DECLARED
-#define TclBN_mp_count_bits_TCL_DECLARED
+EXTERN int TclBN_mp_copy(const mp_int *a, mp_int *b);
/* 12 */
-EXTERN int TclBN_mp_count_bits(mp_int *a);
-#endif
-#ifndef TclBN_mp_div_TCL_DECLARED
-#define TclBN_mp_div_TCL_DECLARED
+EXTERN int TclBN_mp_count_bits(const mp_int *a);
/* 13 */
EXTERN int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q,
mp_int *r);
-#endif
-#ifndef TclBN_mp_div_d_TCL_DECLARED
-#define TclBN_mp_div_d_TCL_DECLARED
/* 14 */
EXTERN int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q,
mp_digit *r);
-#endif
-#ifndef TclBN_mp_div_2_TCL_DECLARED
-#define TclBN_mp_div_2_TCL_DECLARED
/* 15 */
EXTERN int TclBN_mp_div_2(mp_int *a, mp_int *q);
-#endif
-#ifndef TclBN_mp_div_2d_TCL_DECLARED
-#define TclBN_mp_div_2d_TCL_DECLARED
/* 16 */
-EXTERN int TclBN_mp_div_2d(mp_int *a, int b, mp_int *q,
+EXTERN int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
mp_int *r);
-#endif
-#ifndef TclBN_mp_div_3_TCL_DECLARED
-#define TclBN_mp_div_3_TCL_DECLARED
/* 17 */
EXTERN int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r);
-#endif
-#ifndef TclBN_mp_exch_TCL_DECLARED
-#define TclBN_mp_exch_TCL_DECLARED
/* 18 */
EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_expt_d_TCL_DECLARED
-#define TclBN_mp_expt_d_TCL_DECLARED
/* 19 */
EXTERN int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c);
-#endif
-#ifndef TclBN_mp_grow_TCL_DECLARED
-#define TclBN_mp_grow_TCL_DECLARED
/* 20 */
EXTERN int TclBN_mp_grow(mp_int *a, int size);
-#endif
-#ifndef TclBN_mp_init_TCL_DECLARED
-#define TclBN_mp_init_TCL_DECLARED
/* 21 */
EXTERN int TclBN_mp_init(mp_int *a);
-#endif
-#ifndef TclBN_mp_init_copy_TCL_DECLARED
-#define TclBN_mp_init_copy_TCL_DECLARED
/* 22 */
EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_init_multi_TCL_DECLARED
-#define TclBN_mp_init_multi_TCL_DECLARED
/* 23 */
EXTERN int TclBN_mp_init_multi(mp_int *a, ...);
-#endif
-#ifndef TclBN_mp_init_set_TCL_DECLARED
-#define TclBN_mp_init_set_TCL_DECLARED
/* 24 */
EXTERN int TclBN_mp_init_set(mp_int *a, mp_digit b);
-#endif
-#ifndef TclBN_mp_init_size_TCL_DECLARED
-#define TclBN_mp_init_size_TCL_DECLARED
/* 25 */
EXTERN int TclBN_mp_init_size(mp_int *a, int size);
-#endif
-#ifndef TclBN_mp_lshd_TCL_DECLARED
-#define TclBN_mp_lshd_TCL_DECLARED
/* 26 */
EXTERN int TclBN_mp_lshd(mp_int *a, int shift);
-#endif
-#ifndef TclBN_mp_mod_TCL_DECLARED
-#define TclBN_mp_mod_TCL_DECLARED
/* 27 */
EXTERN int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r);
-#endif
-#ifndef TclBN_mp_mod_2d_TCL_DECLARED
-#define TclBN_mp_mod_2d_TCL_DECLARED
/* 28 */
-EXTERN int TclBN_mp_mod_2d(mp_int *a, int b, mp_int *r);
-#endif
-#ifndef TclBN_mp_mul_TCL_DECLARED
-#define TclBN_mp_mul_TCL_DECLARED
+EXTERN int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r);
/* 29 */
EXTERN int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p);
-#endif
-#ifndef TclBN_mp_mul_d_TCL_DECLARED
-#define TclBN_mp_mul_d_TCL_DECLARED
/* 30 */
EXTERN int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p);
-#endif
-#ifndef TclBN_mp_mul_2_TCL_DECLARED
-#define TclBN_mp_mul_2_TCL_DECLARED
/* 31 */
EXTERN int TclBN_mp_mul_2(mp_int *a, mp_int *p);
-#endif
-#ifndef TclBN_mp_mul_2d_TCL_DECLARED
-#define TclBN_mp_mul_2d_TCL_DECLARED
/* 32 */
-EXTERN int TclBN_mp_mul_2d(mp_int *a, int d, mp_int *p);
-#endif
-#ifndef TclBN_mp_neg_TCL_DECLARED
-#define TclBN_mp_neg_TCL_DECLARED
+EXTERN int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p);
/* 33 */
-EXTERN int TclBN_mp_neg(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_or_TCL_DECLARED
-#define TclBN_mp_or_TCL_DECLARED
+EXTERN int TclBN_mp_neg(const mp_int *a, mp_int *b);
/* 34 */
EXTERN int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_radix_size_TCL_DECLARED
-#define TclBN_mp_radix_size_TCL_DECLARED
/* 35 */
EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size);
-#endif
-#ifndef TclBN_mp_read_radix_TCL_DECLARED
-#define TclBN_mp_read_radix_TCL_DECLARED
/* 36 */
-EXTERN int TclBN_mp_read_radix(mp_int *a, CONST char *str,
+EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str,
int radix);
-#endif
-#ifndef TclBN_mp_rshd_TCL_DECLARED
-#define TclBN_mp_rshd_TCL_DECLARED
/* 37 */
EXTERN void TclBN_mp_rshd(mp_int *a, int shift);
-#endif
-#ifndef TclBN_mp_shrink_TCL_DECLARED
-#define TclBN_mp_shrink_TCL_DECLARED
/* 38 */
EXTERN int TclBN_mp_shrink(mp_int *a);
-#endif
-#ifndef TclBN_mp_set_TCL_DECLARED
-#define TclBN_mp_set_TCL_DECLARED
/* 39 */
EXTERN void TclBN_mp_set(mp_int *a, mp_digit b);
-#endif
-#ifndef TclBN_mp_sqr_TCL_DECLARED
-#define TclBN_mp_sqr_TCL_DECLARED
/* 40 */
EXTERN int TclBN_mp_sqr(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_sqrt_TCL_DECLARED
-#define TclBN_mp_sqrt_TCL_DECLARED
/* 41 */
EXTERN int TclBN_mp_sqrt(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_sub_TCL_DECLARED
-#define TclBN_mp_sub_TCL_DECLARED
/* 42 */
EXTERN int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_sub_d_TCL_DECLARED
-#define TclBN_mp_sub_d_TCL_DECLARED
/* 43 */
EXTERN int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c);
-#endif
-#ifndef TclBN_mp_to_unsigned_bin_TCL_DECLARED
-#define TclBN_mp_to_unsigned_bin_TCL_DECLARED
/* 44 */
EXTERN int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b);
-#endif
-#ifndef TclBN_mp_to_unsigned_bin_n_TCL_DECLARED
-#define TclBN_mp_to_unsigned_bin_n_TCL_DECLARED
/* 45 */
EXTERN int TclBN_mp_to_unsigned_bin_n(mp_int *a,
unsigned char *b, unsigned long *outlen);
-#endif
-#ifndef TclBN_mp_toradix_n_TCL_DECLARED
-#define TclBN_mp_toradix_n_TCL_DECLARED
/* 46 */
EXTERN int TclBN_mp_toradix_n(mp_int *a, char *str, int radix,
int maxlen);
-#endif
-#ifndef TclBN_mp_unsigned_bin_size_TCL_DECLARED
-#define TclBN_mp_unsigned_bin_size_TCL_DECLARED
/* 47 */
EXTERN int TclBN_mp_unsigned_bin_size(mp_int *a);
-#endif
-#ifndef TclBN_mp_xor_TCL_DECLARED
-#define TclBN_mp_xor_TCL_DECLARED
/* 48 */
EXTERN int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_zero_TCL_DECLARED
-#define TclBN_mp_zero_TCL_DECLARED
/* 49 */
EXTERN void TclBN_mp_zero(mp_int *a);
-#endif
-#ifndef TclBN_reverse_TCL_DECLARED
-#define TclBN_reverse_TCL_DECLARED
/* 50 */
EXTERN void TclBN_reverse(unsigned char *s, int len);
-#endif
-#ifndef TclBN_fast_s_mp_mul_digs_TCL_DECLARED
-#define TclBN_fast_s_mp_mul_digs_TCL_DECLARED
/* 51 */
EXTERN int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b,
mp_int *c, int digs);
-#endif
-#ifndef TclBN_fast_s_mp_sqr_TCL_DECLARED
-#define TclBN_fast_s_mp_sqr_TCL_DECLARED
/* 52 */
EXTERN int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_karatsuba_mul_TCL_DECLARED
-#define TclBN_mp_karatsuba_mul_TCL_DECLARED
/* 53 */
EXTERN int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b,
mp_int *c);
-#endif
-#ifndef TclBN_mp_karatsuba_sqr_TCL_DECLARED
-#define TclBN_mp_karatsuba_sqr_TCL_DECLARED
/* 54 */
EXTERN int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_mp_toom_mul_TCL_DECLARED
-#define TclBN_mp_toom_mul_TCL_DECLARED
/* 55 */
EXTERN int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_toom_sqr_TCL_DECLARED
-#define TclBN_mp_toom_sqr_TCL_DECLARED
/* 56 */
EXTERN int TclBN_mp_toom_sqr(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_s_mp_add_TCL_DECLARED
-#define TclBN_s_mp_add_TCL_DECLARED
/* 57 */
EXTERN int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_s_mp_mul_digs_TCL_DECLARED
-#define TclBN_s_mp_mul_digs_TCL_DECLARED
/* 58 */
EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c,
int digs);
-#endif
-#ifndef TclBN_s_mp_sqr_TCL_DECLARED
-#define TclBN_s_mp_sqr_TCL_DECLARED
/* 59 */
EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b);
-#endif
-#ifndef TclBN_s_mp_sub_TCL_DECLARED
-#define TclBN_s_mp_sub_TCL_DECLARED
/* 60 */
EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c);
-#endif
-#ifndef TclBN_mp_init_set_int_TCL_DECLARED
-#define TclBN_mp_init_set_int_TCL_DECLARED
/* 61 */
EXTERN int TclBN_mp_init_set_int(mp_int*a, unsigned long i);
-#endif
-#ifndef TclBN_mp_set_int_TCL_DECLARED
-#define TclBN_mp_set_int_TCL_DECLARED
/* 62 */
EXTERN int TclBN_mp_set_int(mp_int*a, unsigned long i);
-#endif
typedef struct TclTomMathStubs {
int magic;
- struct TclTomMathStubHooks *hooks;
+ const struct TclTomMathStubHooks *hooks;
int (*tclBN_epoch) (void); /* 0 */
int (*tclBN_revision) (void); /* 1 */
@@ -474,15 +285,15 @@ typedef struct TclTomMathStubs {
void (*tclBN_mp_clamp) (mp_int *a); /* 5 */
void (*tclBN_mp_clear) (mp_int *a); /* 6 */
void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */
- int (*tclBN_mp_cmp) (mp_int *a, mp_int *b); /* 8 */
- int (*tclBN_mp_cmp_d) (mp_int *a, mp_digit b); /* 9 */
- int (*tclBN_mp_cmp_mag) (mp_int *a, mp_int *b); /* 10 */
- int (*tclBN_mp_copy) (mp_int *a, mp_int *b); /* 11 */
- int (*tclBN_mp_count_bits) (mp_int *a); /* 12 */
+ int (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b); /* 8 */
+ int (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b); /* 9 */
+ int (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */
+ int (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */
+ int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */
int (*tclBN_mp_div) (mp_int *a, mp_int *b, mp_int *q, mp_int *r); /* 13 */
int (*tclBN_mp_div_d) (mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */
int (*tclBN_mp_div_2) (mp_int *a, mp_int *q); /* 15 */
- int (*tclBN_mp_div_2d) (mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */
+ int (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */
int (*tclBN_mp_div_3) (mp_int *a, mp_int *q, mp_digit *r); /* 17 */
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
int (*tclBN_mp_expt_d) (mp_int *a, mp_digit b, mp_int *c); /* 19 */
@@ -494,15 +305,15 @@ typedef struct TclTomMathStubs {
int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */
int (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */
int (*tclBN_mp_mod) (mp_int *a, mp_int *b, mp_int *r); /* 27 */
- int (*tclBN_mp_mod_2d) (mp_int *a, int b, mp_int *r); /* 28 */
+ int (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */
int (*tclBN_mp_mul) (mp_int *a, mp_int *b, mp_int *p); /* 29 */
int (*tclBN_mp_mul_d) (mp_int *a, mp_digit b, mp_int *p); /* 30 */
int (*tclBN_mp_mul_2) (mp_int *a, mp_int *p); /* 31 */
- int (*tclBN_mp_mul_2d) (mp_int *a, int d, mp_int *p); /* 32 */
- int (*tclBN_mp_neg) (mp_int *a, mp_int *b); /* 33 */
+ int (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */
+ int (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */
int (*tclBN_mp_or) (mp_int *a, mp_int *b, mp_int *c); /* 34 */
int (*tclBN_mp_radix_size) (mp_int *a, int radix, int *size); /* 35 */
- int (*tclBN_mp_read_radix) (mp_int *a, CONST char *str, int radix); /* 36 */
+ int (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */
void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
int (*tclBN_mp_shrink) (mp_int *a); /* 38 */
void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */
@@ -534,271 +345,145 @@ typedef struct TclTomMathStubs {
#ifdef __cplusplus
extern "C" {
#endif
-extern TclTomMathStubs *tclTomMathStubsPtr;
+extern const TclTomMathStubs *tclTomMathStubsPtr;
#ifdef __cplusplus
}
#endif
-#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
-#ifndef TclBN_epoch
#define TclBN_epoch \
(tclTomMathStubsPtr->tclBN_epoch) /* 0 */
-#endif
-#ifndef TclBN_revision
#define TclBN_revision \
(tclTomMathStubsPtr->tclBN_revision) /* 1 */
-#endif
-#ifndef TclBN_mp_add
#define TclBN_mp_add \
(tclTomMathStubsPtr->tclBN_mp_add) /* 2 */
-#endif
-#ifndef TclBN_mp_add_d
#define TclBN_mp_add_d \
(tclTomMathStubsPtr->tclBN_mp_add_d) /* 3 */
-#endif
-#ifndef TclBN_mp_and
#define TclBN_mp_and \
(tclTomMathStubsPtr->tclBN_mp_and) /* 4 */
-#endif
-#ifndef TclBN_mp_clamp
#define TclBN_mp_clamp \
(tclTomMathStubsPtr->tclBN_mp_clamp) /* 5 */
-#endif
-#ifndef TclBN_mp_clear
#define TclBN_mp_clear \
(tclTomMathStubsPtr->tclBN_mp_clear) /* 6 */
-#endif
-#ifndef TclBN_mp_clear_multi
#define TclBN_mp_clear_multi \
(tclTomMathStubsPtr->tclBN_mp_clear_multi) /* 7 */
-#endif
-#ifndef TclBN_mp_cmp
#define TclBN_mp_cmp \
(tclTomMathStubsPtr->tclBN_mp_cmp) /* 8 */
-#endif
-#ifndef TclBN_mp_cmp_d
#define TclBN_mp_cmp_d \
(tclTomMathStubsPtr->tclBN_mp_cmp_d) /* 9 */
-#endif
-#ifndef TclBN_mp_cmp_mag
#define TclBN_mp_cmp_mag \
(tclTomMathStubsPtr->tclBN_mp_cmp_mag) /* 10 */
-#endif
-#ifndef TclBN_mp_copy
#define TclBN_mp_copy \
(tclTomMathStubsPtr->tclBN_mp_copy) /* 11 */
-#endif
-#ifndef TclBN_mp_count_bits
#define TclBN_mp_count_bits \
(tclTomMathStubsPtr->tclBN_mp_count_bits) /* 12 */
-#endif
-#ifndef TclBN_mp_div
#define TclBN_mp_div \
(tclTomMathStubsPtr->tclBN_mp_div) /* 13 */
-#endif
-#ifndef TclBN_mp_div_d
#define TclBN_mp_div_d \
(tclTomMathStubsPtr->tclBN_mp_div_d) /* 14 */
-#endif
-#ifndef TclBN_mp_div_2
#define TclBN_mp_div_2 \
(tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */
-#endif
-#ifndef TclBN_mp_div_2d
#define TclBN_mp_div_2d \
(tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */
-#endif
-#ifndef TclBN_mp_div_3
#define TclBN_mp_div_3 \
(tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */
-#endif
-#ifndef TclBN_mp_exch
#define TclBN_mp_exch \
(tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */
-#endif
-#ifndef TclBN_mp_expt_d
#define TclBN_mp_expt_d \
(tclTomMathStubsPtr->tclBN_mp_expt_d) /* 19 */
-#endif
-#ifndef TclBN_mp_grow
#define TclBN_mp_grow \
(tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */
-#endif
-#ifndef TclBN_mp_init
#define TclBN_mp_init \
(tclTomMathStubsPtr->tclBN_mp_init) /* 21 */
-#endif
-#ifndef TclBN_mp_init_copy
#define TclBN_mp_init_copy \
(tclTomMathStubsPtr->tclBN_mp_init_copy) /* 22 */
-#endif
-#ifndef TclBN_mp_init_multi
#define TclBN_mp_init_multi \
(tclTomMathStubsPtr->tclBN_mp_init_multi) /* 23 */
-#endif
-#ifndef TclBN_mp_init_set
#define TclBN_mp_init_set \
(tclTomMathStubsPtr->tclBN_mp_init_set) /* 24 */
-#endif
-#ifndef TclBN_mp_init_size
#define TclBN_mp_init_size \
(tclTomMathStubsPtr->tclBN_mp_init_size) /* 25 */
-#endif
-#ifndef TclBN_mp_lshd
#define TclBN_mp_lshd \
(tclTomMathStubsPtr->tclBN_mp_lshd) /* 26 */
-#endif
-#ifndef TclBN_mp_mod
#define TclBN_mp_mod \
(tclTomMathStubsPtr->tclBN_mp_mod) /* 27 */
-#endif
-#ifndef TclBN_mp_mod_2d
#define TclBN_mp_mod_2d \
(tclTomMathStubsPtr->tclBN_mp_mod_2d) /* 28 */
-#endif
-#ifndef TclBN_mp_mul
#define TclBN_mp_mul \
(tclTomMathStubsPtr->tclBN_mp_mul) /* 29 */
-#endif
-#ifndef TclBN_mp_mul_d
#define TclBN_mp_mul_d \
(tclTomMathStubsPtr->tclBN_mp_mul_d) /* 30 */
-#endif
-#ifndef TclBN_mp_mul_2
#define TclBN_mp_mul_2 \
(tclTomMathStubsPtr->tclBN_mp_mul_2) /* 31 */
-#endif
-#ifndef TclBN_mp_mul_2d
#define TclBN_mp_mul_2d \
(tclTomMathStubsPtr->tclBN_mp_mul_2d) /* 32 */
-#endif
-#ifndef TclBN_mp_neg
#define TclBN_mp_neg \
(tclTomMathStubsPtr->tclBN_mp_neg) /* 33 */
-#endif
-#ifndef TclBN_mp_or
#define TclBN_mp_or \
(tclTomMathStubsPtr->tclBN_mp_or) /* 34 */
-#endif
-#ifndef TclBN_mp_radix_size
#define TclBN_mp_radix_size \
(tclTomMathStubsPtr->tclBN_mp_radix_size) /* 35 */
-#endif
-#ifndef TclBN_mp_read_radix
#define TclBN_mp_read_radix \
(tclTomMathStubsPtr->tclBN_mp_read_radix) /* 36 */
-#endif
-#ifndef TclBN_mp_rshd
#define TclBN_mp_rshd \
(tclTomMathStubsPtr->tclBN_mp_rshd) /* 37 */
-#endif
-#ifndef TclBN_mp_shrink
#define TclBN_mp_shrink \
(tclTomMathStubsPtr->tclBN_mp_shrink) /* 38 */
-#endif
-#ifndef TclBN_mp_set
#define TclBN_mp_set \
(tclTomMathStubsPtr->tclBN_mp_set) /* 39 */
-#endif
-#ifndef TclBN_mp_sqr
#define TclBN_mp_sqr \
(tclTomMathStubsPtr->tclBN_mp_sqr) /* 40 */
-#endif
-#ifndef TclBN_mp_sqrt
#define TclBN_mp_sqrt \
(tclTomMathStubsPtr->tclBN_mp_sqrt) /* 41 */
-#endif
-#ifndef TclBN_mp_sub
#define TclBN_mp_sub \
(tclTomMathStubsPtr->tclBN_mp_sub) /* 42 */
-#endif
-#ifndef TclBN_mp_sub_d
#define TclBN_mp_sub_d \
(tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */
-#endif
-#ifndef TclBN_mp_to_unsigned_bin
#define TclBN_mp_to_unsigned_bin \
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */
-#endif
-#ifndef TclBN_mp_to_unsigned_bin_n
#define TclBN_mp_to_unsigned_bin_n \
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */
-#endif
-#ifndef TclBN_mp_toradix_n
#define TclBN_mp_toradix_n \
(tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */
-#endif
-#ifndef TclBN_mp_unsigned_bin_size
#define TclBN_mp_unsigned_bin_size \
(tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */
-#endif
-#ifndef TclBN_mp_xor
#define TclBN_mp_xor \
(tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */
-#endif
-#ifndef TclBN_mp_zero
#define TclBN_mp_zero \
(tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */
-#endif
-#ifndef TclBN_reverse
#define TclBN_reverse \
(tclTomMathStubsPtr->tclBN_reverse) /* 50 */
-#endif
-#ifndef TclBN_fast_s_mp_mul_digs
#define TclBN_fast_s_mp_mul_digs \
(tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */
-#endif
-#ifndef TclBN_fast_s_mp_sqr
#define TclBN_fast_s_mp_sqr \
(tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */
-#endif
-#ifndef TclBN_mp_karatsuba_mul
#define TclBN_mp_karatsuba_mul \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */
-#endif
-#ifndef TclBN_mp_karatsuba_sqr
#define TclBN_mp_karatsuba_sqr \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */
-#endif
-#ifndef TclBN_mp_toom_mul
#define TclBN_mp_toom_mul \
(tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */
-#endif
-#ifndef TclBN_mp_toom_sqr
#define TclBN_mp_toom_sqr \
(tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */
-#endif
-#ifndef TclBN_s_mp_add
#define TclBN_s_mp_add \
(tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */
-#endif
-#ifndef TclBN_s_mp_mul_digs
#define TclBN_s_mp_mul_digs \
(tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */
-#endif
-#ifndef TclBN_s_mp_sqr
#define TclBN_s_mp_sqr \
(tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */
-#endif
-#ifndef TclBN_s_mp_sub
#define TclBN_s_mp_sub \
(tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */
-#endif
-#ifndef TclBN_mp_init_set_int
#define TclBN_mp_init_set_int \
(tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */
-#endif
-#ifndef TclBN_mp_set_int
#define TclBN_mp_set_int \
(tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */
-#endif
-#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 6e5dac3..775e86b 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -14,9 +14,8 @@
#include "tclInt.h"
#include "tommath.h"
-#include <limits.h>
-extern TclTomMathStubs tclTomMathStubs;
+MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
/*
*----------------------------------------------------------------------
@@ -38,12 +37,12 @@ extern TclTomMathStubs tclTomMathStubs;
int
TclTommath_Init(
- Tcl_Interp* interp /* Tcl interpreter */
-) {
+ Tcl_Interp *interp) /* Tcl interpreter */
+{
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_PATCH_LEVEL,
- (ClientData)&tclTomMathStubs) != TCL_OK) {
+ &tclTomMathStubs) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
@@ -189,7 +188,7 @@ TclBNInitBignumFromLong(
{
int status;
unsigned long v;
- mp_digit* p;
+ mp_digit *p;
/*
* Allocate enough memory to hold the largest possible long
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
new file mode 100644
index 0000000..e7e4aea
--- /dev/null
+++ b/generic/tclTomMathStubLib.c
@@ -0,0 +1,89 @@
+/*
+ * tclTomMathStubLib.c --
+ *
+ * Stub object that will be statically linked into extensions that want
+ * to access Tcl.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1998 Paul Duffin.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * 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;
+
+const TclTomMathStubs *tclTomMathStubsPtr = NULL;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTomMathInitStubs --
+ *
+ * Initializes the Stubs table for Tcl's subset of libtommath
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * This procedure should not be called directly, but rather through
+ * the TclTomMath_InitStubs macro, to insure that the Stubs table
+ * matches the header files used in compilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE const char *
+TclTomMathInitializeStubs(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ const char *version, /* Tcl version needed */
+ int epoch, /* Stubs table epoch from the header files */
+ int revision) /* Stubs table revision number from the
+ * header files */
+{
+ 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;
+
+ if (actualVersion == NULL) {
+ return NULL;
+ }
+ if (pkgClientData == NULL) {
+ errMsg = "missing stub table pointer";
+ } else if ((stubsPtr->tclBN_epoch)() != epoch) {
+ errMsg = "epoch number mismatch";
+ } else if ((stubsPtr->tclBN_revision)() != revision) {
+ errMsg = "requires a later revision";
+ } else {
+ tclTomMathStubsPtr = stubsPtr;
+ return actualVersion;
+ }
+ Tcl_ResetResult(interp);
+ 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/tclTrace.c b/generic/tclTrace.c
index 49c57bc..a60a80b 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -22,11 +22,11 @@ typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
size_t length; /* Number of non-NUL chars. in command. */
- char command[4]; /* Space for Tcl command to invoke. Actual
+ char command[1]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
- * structure, so that it can be larger than 4
- * bytes. */
+ * structure, so that it can be larger than 1
+ * byte. */
} TraceVarInfo;
typedef struct {
@@ -56,11 +56,11 @@ typedef struct {
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
- char command[4]; /* Space for Tcl command to invoke. Actual
+ char command[1]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
- * structure, so that it can be larger than 4
- * bytes. */
+ * structure, so that it can be larger than 1
+ * byte. */
} TraceCommandInfo;
/*
@@ -107,10 +107,10 @@ static Tcl_TraceTypeObjCmd TraceExecutionObjCmd;
* add to the list of supported trace types.
*/
-static const char *traceTypeOptions[] = {
+static const char *const traceTypeOptions[] = {
"execution", "command", "variable", NULL
};
-static Tcl_TraceTypeObjCmd *traceSubCmds[] = {
+static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
TraceExecutionObjCmd,
TraceCommandObjCmd,
TraceVariableObjCmd,
@@ -147,6 +147,21 @@ typedef struct StringTraceData {
ClientData clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
+
+/*
+ * Convenience macros for iterating over the list of traces. Note that each of
+ * these *must* be treated as a command, and *must* have a block following it.
+ */
+
+#define FOREACH_VAR_TRACE(interp, name, clientData) \
+ (clientData) = NULL; \
+ while (((clientData) = Tcl_VarTraceInfo((interp), (name), 0, \
+ TraceVarProc, (clientData))) != NULL)
+
+#define FOREACH_COMMAND_TRACE(interp, name, clientData) \
+ (clientData) = NULL; \
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, \
+ TraceCommandProc, clientData)) != NULL)
/*
*----------------------------------------------------------------------
@@ -176,9 +191,10 @@ Tcl_TraceObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
- char *name, *flagOps, *p;
+ const char *name;
+ const char *flagOps, *p;
/* Main sub commands to 'trace' */
- static const char *traceOptions[] = {
+ static const char *const traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
@@ -194,12 +210,12 @@ Tcl_TraceObjCmd(
};
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
- "option", 0, &optionIndex) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0,
+ &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
@@ -214,14 +230,14 @@ Tcl_TraceObjCmd(
int typeIndex;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "type ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option",
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
}
case TRACE_INFO: {
/*
@@ -244,7 +260,7 @@ Tcl_TraceObjCmd(
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
break;
}
@@ -288,9 +304,9 @@ Tcl_TraceObjCmd(
memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
copyObjv[4] = opsList;
if (optionIndex == TRACE_OLD_VARIABLE) {
- code = (traceSubCmds[2])(interp, TRACE_ADD, objc+1, copyObjv);
+ code = traceSubCmds[2](interp, TRACE_ADD, objc+1, copyObjv);
} else {
- code = (traceSubCmds[2])(interp, TRACE_REMOVE, objc+1, copyObjv);
+ code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
@@ -305,32 +321,29 @@ Tcl_TraceObjCmd(
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
- clientData = 0;
name = Tcl_GetString(objv[2]);
- while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
- TraceVarProc, clientData)) != 0) {
-
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+ FOREACH_VAR_TRACE(interp, name, clientData) {
+ TraceVarInfo *tvarPtr = clientData;
+ char *q = ops;
pairObjPtr = Tcl_NewListObj(0, NULL);
- p = ops;
if (tvarPtr->flags & TCL_TRACE_READS) {
- *p = 'r';
- p++;
+ *q = 'r';
+ q++;
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
- *p = 'w';
- p++;
+ *q = 'w';
+ q++;
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- *p = 'u';
- p++;
+ *q = 'u';
+ q++;
}
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
- *p = 'a';
- p++;
+ *q = 'a';
+ q++;
}
- *p = '\0';
+ *q = '\0';
/*
* Build a pair (2-item list) with the ops string as the first obj
@@ -355,6 +368,7 @@ Tcl_TraceObjCmd(
badVarOps:
Tcl_AppendResult(interp, "bad operations \"", flagOps,
"\": should be one or more of rwua", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
@@ -385,12 +399,12 @@ TraceExecutionObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
- char *name, *command;
+ const char *name, *command;
size_t length;
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE
};
- static const char *opStrings[] = {
+ static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
enum operations {
@@ -423,6 +437,8 @@ TraceExecutionObjCmd(
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of enter, leave, enterstep, or leavestep",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
@@ -448,11 +464,9 @@ TraceExecutionObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr;
+ TraceCommandInfo *tcmdPtr = ckalloc(
+ TclOffset(TraceCommandInfo, command) + 1 + length);
- tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
- (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
- + length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
@@ -467,8 +481,8 @@ TraceExecutionObjCmd(
memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
- (ClientData) tcmdPtr) != TCL_OK) {
- ckfree((char *) tcmdPtr);
+ tcmdPtr) != TCL_OK) {
+ ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
@@ -478,21 +492,19 @@ TraceExecutionObjCmd(
* first one that matches.
*/
- TraceCommandInfo *tcmdPtr;
- ClientData clientData = NULL;
- name = Tcl_GetString(objv[3]);
+ ClientData clientData;
/*
* First ensure the name given is valid.
*/
+ name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
- while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
- TraceCommandProc, clientData)) != NULL) {
- tcmdPtr = (TraceCommandInfo *) clientData;
+ FOREACH_COMMAND_TRACE(interp, name, clientData) {
+ TraceCommandInfo *tcmdPtr = clientData;
/*
* In checking the 'flags' field we must remove any extraneous
@@ -521,7 +533,7 @@ TraceExecutionObjCmd(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -532,7 +544,7 @@ TraceExecutionObjCmd(
tcmdPtr->flags = 0;
}
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
break;
}
@@ -542,14 +554,13 @@ TraceExecutionObjCmd(
}
case TRACE_INFO: {
ClientData clientData;
- Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
- clientData = NULL;
name = Tcl_GetString(objv[3]);
/*
@@ -561,11 +572,10 @@ TraceExecutionObjCmd(
}
resultListPtr = Tcl_NewListObj(0, NULL);
- while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
- TraceCommandProc, clientData)) != NULL) {
+ FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
- Tcl_Obj *opObj;
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
+ TraceCommandInfo *tcmdPtr = clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -639,10 +649,10 @@ TraceCommandObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
- char *name, *command;
+ const char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
- static const char *opStrings[] = { "delete", "rename", NULL };
+ static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
@@ -669,6 +679,8 @@ TraceCommandObjCmd(
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of delete or rename", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
@@ -690,11 +702,9 @@ TraceCommandObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr;
+ TraceCommandInfo *tcmdPtr = ckalloc(
+ TclOffset(TraceCommandInfo, command) + 1 + length);
- tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
- (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
- + length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
@@ -705,8 +715,8 @@ TraceCommandObjCmd(
memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
- (ClientData) tcmdPtr) != TCL_OK) {
- ckfree((char *) tcmdPtr);
+ tcmdPtr) != TCL_OK) {
+ ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
@@ -716,30 +726,28 @@ TraceCommandObjCmd(
* first one that matches.
*/
- TraceCommandInfo *tcmdPtr;
- ClientData clientData = NULL;
- name = Tcl_GetString(objv[3]);
+ ClientData clientData;
/*
* First ensure the name given is valid.
*/
+ name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
- while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
- TraceCommandProc, clientData)) != NULL) {
- tcmdPtr = (TraceCommandInfo *) clientData;
- if ((tcmdPtr->length == length)
- && (tcmdPtr->flags == flags)
+ FOREACH_COMMAND_TRACE(interp, name, clientData) {
+ TraceCommandInfo *tcmdPtr = clientData;
+
+ if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
break;
}
@@ -749,30 +757,27 @@ TraceCommandObjCmd(
}
case TRACE_INFO: {
ClientData clientData;
- Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
- clientData = NULL;
- name = Tcl_GetString(objv[3]);
-
/*
* First ensure the name given is valid.
*/
+ name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
- while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
- TraceCommandProc, clientData)) != NULL) {
+ FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
- Tcl_Obj *opObj;
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
+ TraceCommandInfo *tcmdPtr = clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -837,10 +842,11 @@ TraceVariableObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
- char *name, *command;
+ const char *name, *command;
size_t length;
+ ClientData clientData;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
- static const char *opStrings[] = {
+ static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
};
enum operations {
@@ -871,6 +877,8 @@ TraceVariableObjCmd(
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of array, read, unset, or write", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
@@ -896,11 +904,10 @@ TraceVariableObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- CombinedTraceVarInfo *ctvarPtr;
+ CombinedTraceVarInfo *ctvarPtr = ckalloc(
+ TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+ + 1 + length);
- ctvarPtr = (CombinedTraceVarInfo *) ckalloc((unsigned)
- (sizeof(CombinedTraceVarInfo) + length + 1
- - sizeof(ctvarPtr->traceCmdInfo.command)));
ctvarPtr->traceCmdInfo.flags = flags;
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
@@ -909,12 +916,12 @@ TraceVariableObjCmd(
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
ctvarPtr->traceInfo.traceProc = TraceVarProc;
- ctvarPtr->traceInfo.clientData = (ClientData)
- &ctvarPtr->traceCmdInfo;
+ ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo;
ctvarPtr->traceInfo.flags = flags;
name = Tcl_GetString(objv[3]);
- if (TraceVarEx(interp,name,NULL,(VarTrace*)ctvarPtr) != TCL_OK) {
- ckfree((char *) ctvarPtr);
+ if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
+ != TCL_OK) {
+ ckfree(ctvarPtr);
return TCL_ERROR;
}
} else {
@@ -924,12 +931,10 @@ TraceVariableObjCmd(
* first one that matches.
*/
- TraceVarInfo *tvarPtr;
- ClientData clientData = 0;
name = Tcl_GetString(objv[3]);
- while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
- TraceVarProc, clientData)) != 0) {
- tvarPtr = (TraceVarInfo *) clientData;
+ FOREACH_VAR_TRACE(interp, name, clientData) {
+ TraceVarInfo *tvarPtr = clientData;
+
if ((tvarPtr->length == length)
&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
&& (strncmp(command, tvarPtr->command,
@@ -944,8 +949,7 @@ TraceVariableObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
- Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
@@ -953,12 +957,10 @@ TraceVariableObjCmd(
}
resultListPtr = Tcl_NewObj();
- clientData = 0;
name = Tcl_GetString(objv[3]);
- while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc,
- clientData)) != 0) {
- Tcl_Obj *opObj;
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+ FOREACH_VAR_TRACE(interp, name, clientData) {
+ Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr;
+ TraceVarInfo *tvarPtr = clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -968,20 +970,20 @@ TraceVariableObjCmd(
elemObjPtr = Tcl_NewListObj(0, NULL);
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
- TclNewLiteralStringObj(opObj, "array");
- Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
+ TclNewLiteralStringObj(opObjPtr, "array");
+ Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr);
}
if (tvarPtr->flags & TCL_TRACE_READS) {
- TclNewLiteralStringObj(opObj, "read");
- Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
+ TclNewLiteralStringObj(opObjPtr, "read");
+ Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr);
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
- TclNewLiteralStringObj(opObj, "write");
- Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
+ TclNewLiteralStringObj(opObjPtr, "write");
+ Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr);
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- TclNewLiteralStringObj(opObj, "unset");
- Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
+ TclNewLiteralStringObj(opObjPtr, "unset");
+ Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr);
}
eachTraceObjPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
@@ -1113,7 +1115,7 @@ Tcl_TraceCommand(
* Set up trace information.
*/
- tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
+ tracePtr = ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
@@ -1209,7 +1211,7 @@ Tcl_UntraceCommand(
tracePtr->flags = 0;
if ((--tracePtr->refCount) <= 0) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
if (hasExecTraces) {
@@ -1259,7 +1261,7 @@ TraceCommandProc(
int flags) /* OR-ed bits giving operation and other
* information. */
{
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ TraceCommandInfo *tcmdPtr = clientData;
int code;
Tcl_DString cmd;
@@ -1316,7 +1318,7 @@ TraceCommandProc(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -1355,11 +1357,11 @@ TraceCommandProc(
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
- (void) Tcl_RestoreInterpState(interp, state);
+ Tcl_RestoreInterpState(interp, state);
tcmdPtr->refCount--;
}
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
@@ -1439,8 +1441,7 @@ TclCheckExecutionTraces(
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
- tracePtr->clientData;
+ TraceCommandInfo *tcmdPtr = tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
@@ -1449,10 +1450,10 @@ TclCheckExecutionTraces(
if (state == NULL) {
state = Tcl_SaveInterpState(interp, code);
}
- traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp,
- curLevel, command, (Tcl_Command) cmdPtr, objc, objv);
+ traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
+ command, (Tcl_Command) cmdPtr, objc, objv);
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
}
@@ -1462,10 +1463,10 @@ TclCheckExecutionTraces(
}
iPtr->activeCmdTracePtr = active.nextPtr;
if (state) {
- (void) Tcl_RestoreInterpState(interp, state);
+ Tcl_RestoreInterpState(interp, state);
}
- return(traceCode);
+ return traceCode;
}
/*
@@ -1563,7 +1564,7 @@ TclCheckInterpTraces(
* it.
*/
- Tcl_Preserve((ClientData) tracePtr);
+ Tcl_Preserve(tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if (state == NULL) {
state = Tcl_SaveInterpState(interp, code);
@@ -1577,15 +1578,14 @@ TclCheckInterpTraces(
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
- tracePtr->clientData;
+ TraceCommandInfo *tcmdPtr = tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
- traceCode = (tracePtr->proc)(tracePtr->clientData,
- interp, curLevel, command, (Tcl_Command) cmdPtr,
- objc, objv);
+ traceCode = tracePtr->proc(tracePtr->clientData, interp,
+ curLevel, command, (Tcl_Command) cmdPtr, objc,
+ objv);
}
} else {
/*
@@ -1603,19 +1603,19 @@ TclCheckInterpTraces(
}
}
tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
- Tcl_Release((ClientData) tracePtr);
+ Tcl_Release(tracePtr);
}
}
iPtr->activeInterpTracePtr = active.nextPtr;
if (state) {
if (traceCode == TCL_OK) {
- (void) Tcl_RestoreInterpState(interp, state);
+ Tcl_RestoreInterpState(interp, state);
} else {
Tcl_DiscardInterpState(state);
}
}
- return(traceCode);
+ return traceCode;
}
/*
@@ -1657,7 +1657,7 @@ CallTraceFunction(
* Copy the command characters into a new string.
*/
- commandCopy = TclStackAlloc(interp, (unsigned) (numChars + 1));
+ commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1);
memcpy(commandCopy, command, (size_t) numChars);
commandCopy[numChars] = '\0';
@@ -1665,7 +1665,7 @@ CallTraceFunction(
* Call the trace function then free allocated storage.
*/
- traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr,
+ traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr,
iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv);
TclStackFree(interp, commandCopy);
@@ -1693,10 +1693,10 @@ static void
CommandObjTraceDeleted(
ClientData clientData)
{
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ TraceCommandInfo *tcmdPtr = clientData;
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
@@ -1737,7 +1737,7 @@ TraceExecutionProc(
{
int call = 0;
Interp *iPtr = (Interp *) interp;
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ TraceCommandInfo *tcmdPtr = clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
@@ -1779,7 +1779,7 @@ TraceExecutionProc(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
@@ -1788,8 +1788,7 @@ TraceExecutionProc(
*/
if (call) {
- Tcl_DString cmd;
- Tcl_DString sub;
+ Tcl_DString cmd, sub;
int i, saveInterpFlags;
Tcl_DStringInit(&cmd);
@@ -1818,7 +1817,7 @@ TraceExecutionProc(
}
} else if (flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_Obj *resultCode;
- char *resultCodeStr;
+ const char *resultCodeStr;
/*
* Append result code.
@@ -1898,8 +1897,7 @@ TraceExecutionProc(
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
- TraceExecutionProc, (ClientData)tcmdPtr,
- CommandObjTraceDeleted);
+ TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted);
}
}
if (flags & TCL_TRACE_DESTROYED) {
@@ -1913,7 +1911,7 @@ TraceExecutionProc(
}
if (call) {
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
return traceCode;
@@ -1948,10 +1946,11 @@ TraceVarProc(
int flags) /* OR-ed bits giving operation and other
* information. */
{
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+ TraceVarInfo *tvarPtr = clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
+ int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
* We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
@@ -2013,10 +2012,23 @@ TraceVarProc(
destroy = 1;
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
+
+ /*
+ * Make sure that unset traces are rune even if the execEnv is
+ * rewinding (coroutine deletion, [Bug 2093947]
+ */
+
+ if (rewind && (flags & TCL_TRACE_UNSETS)) {
+ ((Interp *)interp)->execEnvPtr->rewind = 0;
+ }
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
+ if (rewind) {
+ ((Interp *)interp)->execEnvPtr->rewind = rewind;
+ }
if (code != TCL_OK) { /* copy error msg to result */
Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
@@ -2126,7 +2138,7 @@ Tcl_CreateObjTrace(
iPtr->tracesForbiddingInline++;
}
- tracePtr = (Trace *) ckalloc(sizeof(Trace));
+ tracePtr = ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
@@ -2189,13 +2201,12 @@ Tcl_CreateTrace(
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
- StringTraceData *data = (StringTraceData *)
- ckalloc(sizeof(StringTraceData));
+ StringTraceData *data = ckalloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
- (ClientData) data, StringTraceDeleteProc);
+ data, StringTraceDeleteProc);
}
/*
@@ -2224,7 +2235,7 @@ StringTraceProc(
int objc,
Tcl_Obj *const *objv)
{
- StringTraceData *data = (StringTraceData *) clientData;
+ StringTraceData *data = clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
int i;
@@ -2247,7 +2258,7 @@ StringTraceProc(
* either command or argv.
*/
- (data->proc)(data->clientData, interp, level, (char *) command,
+ data->proc(data->clientData, interp, level, (char *) command,
cmdPtr->proc, cmdPtr->clientData, objc, argv);
TclStackFree(interp, (void *) argv);
@@ -2274,7 +2285,7 @@ static void
StringTraceDeleteProc(
ClientData clientData)
{
- ckfree((char *) clientData);
+ ckfree(clientData);
}
/*
@@ -2302,7 +2313,7 @@ Tcl_DeleteTrace(
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
- register Trace **tracePtr2 = &(iPtr->tracePtr);
+ register Trace **tracePtr2 = &iPtr->tracePtr;
ActiveInterpTrace *activePtr;
/*
@@ -2311,14 +2322,14 @@ Tcl_DeleteTrace(
*/
prevPtr = NULL;
- while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
+ while (*tracePtr2 != NULL && *tracePtr2 != tracePtr) {
prevPtr = *tracePtr2;
- tracePtr2 = &((*tracePtr2)->nextPtr);
+ tracePtr2 = &prevPtr->nextPtr;
}
if (*tracePtr2 == NULL) {
return;
}
- (*tracePtr2) = (*tracePtr2)->nextPtr;
+ *tracePtr2 = (*tracePtr2)->nextPtr;
/*
* The code below makes it possible to delete traces while traces are
@@ -2357,7 +2368,7 @@ Tcl_DeleteTrace(
*/
if (tracePtr->delProc != NULL) {
- (tracePtr->delProc)(tracePtr->clientData);
+ tracePtr->delProc(tracePtr->clientData);
}
/*
@@ -2390,8 +2401,7 @@ TclVarTraceExists(
Tcl_Interp *interp, /* The interpreter */
const char *varName) /* The variable name */
{
- Var *varPtr;
- Var *arrayPtr;
+ Var *varPtr, *arrayPtr;
/*
* The choice of "create" flag values is delicate here, and matches the
@@ -2411,7 +2421,7 @@ TclVarTraceExists(
if ((varPtr->flags & VAR_TRACED_READ)
|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
- TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
+ TclCallVarTraces((Interp *) interp, arrayPtr, varPtr, varName, NULL,
TCL_TRACE_READS, /* leaveErrMsg */ 0);
}
@@ -2470,7 +2480,7 @@ TclObjCallVarTraces(
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
- char *part1, *part2;
+ const char *part1, *part2;
if (!part1Ptr) {
part1Ptr = localName(iPtr->varFramePtr, index);
@@ -2574,25 +2584,25 @@ TclCallVarTraces(
result = NULL;
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
- Tcl_Preserve((ClientData) iPtr);
+ Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
- for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
- tracePtr != NULL; tracePtr = active.nextTracePtr) {
+ for (tracePtr = Tcl_GetHashValue(hPtr);
+ tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
- Tcl_Preserve((ClientData) tracePtr);
+ Tcl_Preserve(tracePtr);
if (state == NULL) {
- state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
+ state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code);
}
- if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
+ if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
- result = (*tracePtr->traceProc)(tracePtr->clientData,
+ result = tracePtr->traceProc(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
@@ -2606,7 +2616,7 @@ TclCallVarTraces(
code = TCL_ERROR;
}
}
- Tcl_Release((ClientData) tracePtr);
+ Tcl_Release(tracePtr);
if (code == TCL_ERROR) {
goto done;
}
@@ -2623,20 +2633,20 @@ TclCallVarTraces(
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
- tracePtr != NULL; tracePtr = active.nextTracePtr) {
+ for (tracePtr = Tcl_GetHashValue(hPtr);
+ tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
- Tcl_Preserve((ClientData) tracePtr);
+ Tcl_Preserve(tracePtr);
if (state == NULL) {
- state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
+ state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code);
}
- if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
+ if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
- result = (*tracePtr->traceProc)(tracePtr->clientData,
+ result = tracePtr->traceProc(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
@@ -2650,7 +2660,7 @@ TclCallVarTraces(
code = TCL_ERROR;
}
}
- Tcl_Release((ClientData) tracePtr);
+ Tcl_Release(tracePtr);
if (code == TCL_ERROR) {
goto done;
}
@@ -2703,12 +2713,12 @@ TclCallVarTraces(
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_DiscardInterpState(state);
} else {
- (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
+ Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
}
DisposeTraceResult(disposeFlags,result);
} else if (state) {
if (code == TCL_OK) {
- code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
+ code = Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
} else {
Tcl_DiscardInterpState(state);
}
@@ -2725,7 +2735,7 @@ TclCallVarTraces(
VarHashRefCount(varPtr)--;
}
iPtr->activeVarTracePtr = active.nextPtr;
- Tcl_Release((ClientData) iPtr);
+ Tcl_Release(iPtr);
return code;
}
@@ -2856,9 +2866,8 @@ Tcl_UntraceVar2(
#endif
flags &= flagMask;
- hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
- (char *) varPtr);
- for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
+ for (tracePtr = Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
goto updateFlags;
@@ -2893,7 +2902,7 @@ Tcl_UntraceVar2(
prevPtr->nextPtr = nextPtr;
}
tracePtr->nextPtr = NULL;
- Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(tracePtr, TCL_DYNAMIC);
for (tracePtr = nextPtr; tracePtr != NULL;
tracePtr = tracePtr->nextPtr) {
@@ -2987,7 +2996,6 @@ Tcl_VarTraceInfo2(
* call will return the first trace. */
{
Interp *iPtr = (Interp *) interp;
- register VarTrace *tracePtr;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
@@ -3002,14 +3010,13 @@ Tcl_VarTraceInfo2(
* Find the relevant trace, if any, and return its clientData.
*/
- hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
- (char *) varPtr);
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
- tracePtr = Tcl_GetHashValue(hPtr);
+ register VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
if (prevClientData != NULL) {
- for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
+ for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
@@ -3017,7 +3024,7 @@ Tcl_VarTraceInfo2(
}
}
}
- for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
+ for (; tracePtr != NULL ; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
@@ -3104,7 +3111,7 @@ Tcl_TraceVar2(
register VarTrace *tracePtr;
int result;
- tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
+ tracePtr = ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
@@ -3112,7 +3119,7 @@ Tcl_TraceVar2(
result = TraceVarEx(interp, part1, part2, tracePtr);
if (result != TCL_OK) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
return result;
}
@@ -3178,8 +3185,8 @@ TraceVarEx(
* because there should be no code path that ever sets both flags.
*/
- if ((tracePtr->flags&TCL_TRACE_RESULT_DYNAMIC)
- && (tracePtr->flags&TCL_TRACE_RESULT_OBJECT)) {
+ if ((tracePtr->flags & TCL_TRACE_RESULT_DYNAMIC)
+ && (tracePtr->flags & TCL_TRACE_RESULT_OBJECT)) {
Tcl_Panic("bad result flag combination");
}
@@ -3194,13 +3201,13 @@ TraceVarEx(
#endif
tracePtr->flags = tracePtr->flags & flagMask;
- hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew);
+ hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
- tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+ tracePtr->nextPtr = Tcl_GetHashValue(hPtr);
}
- Tcl_SetHashValue(hPtr, (char *) tracePtr);
+ Tcl_SetHashValue(hPtr, tracePtr);
/*
* Mark the variable as traced so we know to call them.
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index c545e66..efaccb7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -60,7 +60,7 @@
* UTF-8.
*/
-static CONST unsigned char totalBytes[256] = {
+static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
@@ -232,13 +232,13 @@ Tcl_UniCharToUtf(
char *
Tcl_UniCharToUtfDString(
- CONST Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
+ const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
int uniLength, /* Length of Unicode string in Tcl_UniChars
* (must be >= 0). */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
- CONST Tcl_UniChar *w, *wEnd;
+ const Tcl_UniChar *w, *wEnd;
char *p, *string;
int oldLength;
@@ -290,7 +290,7 @@ Tcl_UniCharToUtfDString(
int
Tcl_UtfToUniChar(
- register CONST char *src, /* The UTF-8 string. */
+ register const char *src, /* The UTF-8 string. */
register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
* the UTF-8 string. */
{
@@ -394,7 +394,7 @@ Tcl_UtfToUniChar(
Tcl_UniChar *
Tcl_UtfToUniCharDString(
- CONST char *src, /* UTF-8 string to convert to Unicode. */
+ const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
@@ -402,7 +402,7 @@ Tcl_UtfToUniCharDString(
* DString. */
{
Tcl_UniChar *w, *wString;
- CONST char *p, *end;
+ const char *p, *end;
int oldLength;
if (length < 0) {
@@ -415,6 +415,7 @@ Tcl_UtfToUniCharDString(
*/
oldLength = Tcl_DStringLength(dsPtr);
+/* TODO: fix overreach! */
Tcl_DStringSetLength(dsPtr,
(int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
@@ -453,7 +454,7 @@ Tcl_UtfToUniCharDString(
int
Tcl_UtfCharComplete(
- CONST char *src, /* String to check if first few bytes contain
+ const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
int length) /* Length of above string in bytes. */
{
@@ -483,7 +484,7 @@ Tcl_UtfCharComplete(
int
Tcl_NumUtfChars(
- register CONST char *src, /* The UTF-8 string to measure. */
+ register const char *src, /* The UTF-8 string to measure. */
int length) /* The length of the string in bytes, or -1
* for strlen(string). */
{
@@ -541,9 +542,9 @@ Tcl_NumUtfChars(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_UtfFindFirst(
- CONST char *src, /* The UTF-8 string to be searched. */
+ const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Tcl_UniChar to search for. */
{
int len;
@@ -580,14 +581,14 @@ Tcl_UtfFindFirst(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_UtfFindLast(
- CONST char *src, /* The UTF-8 string to be searched. */
+ const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Tcl_UniChar to search for. */
{
int len;
Tcl_UniChar find;
- CONST char *last;
+ const char *last;
last = NULL;
while (1) {
@@ -622,9 +623,9 @@ Tcl_UtfFindLast(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_UtfNext(
- CONST char *src) /* The current location in the string. */
+ const char *src) /* The current location in the string. */
{
Tcl_UniChar ch;
@@ -652,13 +653,13 @@ Tcl_UtfNext(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_UtfPrev(
- CONST char *src, /* The current location in the string. */
- CONST char *start) /* Pointer to the beginning of the string, to
+ const char *src, /* The current location in the string. */
+ const char *start) /* Pointer to the beginning of the string, to
* avoid going backwards too far. */
{
- CONST char *look;
+ const char *look;
int i, byte;
src--;
@@ -701,10 +702,10 @@ Tcl_UtfPrev(
Tcl_UniChar
Tcl_UniCharAtIndex(
- register CONST char *src, /* The UTF-8 string to dereference. */
+ register const char *src, /* The UTF-8 string to dereference. */
register int index) /* The position of the desired character. */
{
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
while (index >= 0) {
index--;
@@ -730,9 +731,9 @@ Tcl_UniCharAtIndex(
*---------------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_UtfAtIndex(
- register CONST char *src, /* The UTF-8 string. */
+ register const char *src, /* The UTF-8 string. */
register int index) /* The position of the desired character. */
{
Tcl_UniChar ch;
@@ -772,7 +773,7 @@ Tcl_UtfAtIndex(
int
Tcl_UtfBackslash(
- CONST char *src, /* Points to the backslash character of a
+ const char *src, /* Points to the backslash character of a
* backslash sequence. */
int *readPtr, /* Fill in with number of characters read from
* src, unless NULL. */
@@ -984,8 +985,8 @@ Tcl_UtfToTitle(
int
TclpUtfNcmp2(
- CONST char *cs, /* UTF string to compare to ct. */
- CONST char *ct, /* UTF string cs is compared to. */
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct, /* UTF string cs is compared to. */
unsigned long numBytes) /* Number of *bytes* to compare. */
{
/*
@@ -1031,8 +1032,8 @@ TclpUtfNcmp2(
int
Tcl_UtfNcmp(
- CONST char *cs, /* UTF string to compare to ct. */
- CONST char *ct, /* UTF string cs is compared to. */
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct, /* UTF string cs is compared to. */
unsigned long numChars) /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1, ch2;
@@ -1079,8 +1080,8 @@ Tcl_UtfNcmp(
int
Tcl_UtfNcasecmp(
- CONST char *cs, /* UTF string to compare to ct. */
- CONST char *ct, /* UTF string cs is compared to. */
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct, /* UTF string cs is compared to. */
unsigned long numChars) /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1, ch2;
@@ -1216,7 +1217,7 @@ Tcl_UniCharToTitle(
int
Tcl_UniCharLen(
- CONST Tcl_UniChar *uniStr) /* Unicode string to find length of. */
+ const Tcl_UniChar *uniStr) /* Unicode string to find length of. */
{
int len = 0;
@@ -1246,8 +1247,8 @@ Tcl_UniCharLen(
int
Tcl_UniCharNcmp(
- CONST Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
- CONST Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
+ const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
+ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of unichars to compare. */
{
#ifdef WORDS_BIGENDIAN
@@ -1291,8 +1292,8 @@ Tcl_UniCharNcmp(
int
Tcl_UniCharNcasecmp(
- CONST Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
- CONST Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
+ const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
+ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of unichars to compare. */
{
for ( ; numChars != 0; numChars--, ucs++, uct++) {
@@ -1606,8 +1607,8 @@ Tcl_UniCharIsWordChar(
int
Tcl_UniCharCaseMatch(
- CONST Tcl_UniChar *uniStr, /* Unicode String. */
- CONST Tcl_UniChar *uniPattern,
+ const Tcl_UniChar *uniStr, /* Unicode String. */
+ const Tcl_UniChar *uniPattern,
/* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
@@ -1794,14 +1795,14 @@ Tcl_UniCharCaseMatch(
int
TclUniCharMatch(
- CONST Tcl_UniChar *string, /* Unicode String. */
+ const Tcl_UniChar *string, /* Unicode String. */
int strLen, /* Length of String */
- CONST Tcl_UniChar *pattern, /* Pattern, which may contain special
+ const Tcl_UniChar *pattern, /* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
- CONST Tcl_UniChar *stringEnd, *patternEnd;
+ const Tcl_UniChar *stringEnd, *patternEnd;
Tcl_UniChar p;
stringEnd = string + strLen;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 4a7f79f..e8eee7a 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -13,7 +13,6 @@
*/
#include "tclInt.h"
-#include <float.h>
#include <math.h>
/*
@@ -42,11 +41,11 @@ static ProcessGlobalValue executableName = {
* BRACES_UNMATCHED - 1 means that braces aren't properly matched in
* the argument.
* TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash
- * character ('#') should *not* be quoted. This
- * is appropriate when the caller can guarantee
- * the element is not the first element of a
- * list, so [eval] cannot mis-parse the element
- * as a comment.
+ * character ('#') should *not* be quoted. This
+ * is appropriate when the caller can guarantee
+ * the element is not the first element of a
+ * list, so [eval] cannot mis-parse the element
+ * as a comment.
*/
#define USE_BRACES 2
@@ -67,9 +66,9 @@ static void ClearHash(Tcl_HashTable *tablePtr);
static void FreeProcessGlobalValue(ClientData clientData);
static void FreeThreadHash(ClientData clientData);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
-static int SetEndOffsetFromAny(Tcl_Interp* interp,
- Tcl_Obj* objPtr);
-static void UpdateStringOfEndOffset(Tcl_Obj* objPtr);
+static int SetEndOffsetFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
/*
* The following is the Tcl object type definition for an object that
@@ -78,7 +77,7 @@ static void UpdateStringOfEndOffset(Tcl_Obj* objPtr);
* integer, so no memory management is required for it.
*/
-Tcl_ObjType tclEndOffsetType = {
+const Tcl_ObjType tclEndOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
@@ -177,13 +176,13 @@ TclFindElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
- CONST char *list, /* Points to the first byte of a string
+ const char *list, /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
- CONST char **elementPtr, /* Where to put address of first significant
+ const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
- CONST char **nextPtr, /* Fill in with location of character just
+ const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr, /* If non-zero, fill in with size of
@@ -191,14 +190,14 @@ TclFindElement(
int *bracePtr) /* If non-zero, fill in with non-zero/zero to
* indicate that arg was/wasn't in braces. */
{
- CONST char *p = list;
- CONST char *elemStart; /* Points to first byte of first element. */
- CONST char *limit; /* Points just after list's last byte. */
+ const char *p = list;
+ const char *elemStart; /* Points to first byte of first element. */
+ const char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0; /* lint. */
int numChars;
- CONST char *p2;
+ const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
@@ -272,6 +271,8 @@ TclFindElement(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list element in braces followed by \"%.*s\" "
"instead of space", (int) (p2-p), p));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+ NULL);
}
return TCL_ERROR;
}
@@ -329,6 +330,8 @@ TclFindElement(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list element in quotes followed by \"%.*s\" "
"instead of space", (int) (p2-p), p));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+ NULL);
}
return TCL_ERROR;
}
@@ -346,12 +349,16 @@ TclFindElement(
if (interp != NULL) {
Tcl_SetResult(interp, "unmatched open brace in list",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
+ NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
Tcl_SetResult(interp, "unmatched open quote in list",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
+ NULL);
}
return TCL_ERROR;
}
@@ -392,7 +399,7 @@ TclFindElement(
int
TclCopyAndCollapse(
int count, /* Number of byte to copy from src. */
- CONST char *src, /* Copy from here... */
+ const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
int newCount = 0;
@@ -451,13 +458,13 @@ int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, no error message is left. */
- CONST char *list, /* Pointer to string with list structure. */
+ const char *list, /* Pointer to string with list structure. */
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
- CONST char ***argvPtr) /* Pointer to place to store pointer to array
+ const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
- CONST char **argv, *end, *element;
+ const char **argv, *end, *element;
char *p;
int length, size, i, result, elSize, brace;
@@ -470,27 +477,28 @@ Tcl_SplitList(
size = TclCountSpaceRuns(list, -1, &end) + 2;
length = end - list;
- argv = (CONST char **) ckalloc((unsigned)
- ((size * sizeof(char *)) + length + 1));
+ argv = ckalloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
- CONST char *prevList = list;
+ const char *prevList = list;
result = TclFindElement(interp, list, length, &element, &list,
&elSize, &brace);
length -= (list - prevList);
if (result != TCL_OK) {
- ckfree((char *) argv);
+ ckfree(argv);
return result;
}
if (*element == 0) {
break;
}
if (i >= size) {
- ckfree((char *) argv);
+ ckfree(argv);
if (interp != NULL) {
Tcl_SetResult(interp, "internal error in Tcl_SplitList",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
+ NULL);
}
return TCL_ERROR;
}
@@ -535,7 +543,7 @@ Tcl_SplitList(
int
Tcl_ScanElement(
- register CONST char *string,/* String to convert to list element. */
+ register const char *string,/* String to convert to list element. */
register int *flagPtr) /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
@@ -567,13 +575,13 @@ Tcl_ScanElement(
int
Tcl_ScanCountedElement(
- CONST char *string, /* String to convert to Tcl list element. */
+ const char *string, /* String to convert to Tcl list element. */
int length, /* Number of bytes in string, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
- register CONST char *p, *lastChar;
+ register const char *p, *lastChar;
/*
* This function and Tcl_ConvertElement together do two things:
@@ -588,7 +596,7 @@ Tcl_ScanCountedElement(
* "{abc": the leading brace will have to be backslashed. For each
* element, one of three things must be done:
*
- * (a) Use the element as-is (it doesn't contain any special
+ * (a) Use the element as-is (it doesn't contain any special
* characters). This is the most desirable option.
*
* (b) Enclose the element in braces, but leave the contents alone.
@@ -700,7 +708,7 @@ Tcl_ScanCountedElement(
int
Tcl_ConvertElement(
- register CONST char *src, /* Source information for list element. */
+ register const char *src, /* Source information for list element. */
register char *dst, /* Place to put list-ified element. */
register int flags) /* Flags produced by Tcl_ScanElement. */
{
@@ -730,13 +738,13 @@ Tcl_ConvertElement(
int
Tcl_ConvertCountedElement(
- register CONST char *src, /* Source information for list element. */
+ register const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
register char *p = dst;
- register CONST char *lastChar;
+ register const char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement code for
@@ -879,7 +887,7 @@ Tcl_ConvertCountedElement(
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
- CONST char * CONST *argv) /* Array of string values. */
+ const char *const *argv) /* Array of string values. */
{
# define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr;
@@ -895,7 +903,7 @@ Tcl_Merge(
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
+ flagPtr = ckalloc(argc * sizeof(int));
}
numChars = 1;
for (i = 0; i < argc; i++) {
@@ -906,7 +914,7 @@ Tcl_Merge(
* Pass two: copy into the result area.
*/
- result = (char *) ckalloc((unsigned) numChars);
+ result = ckalloc(numChars);
dst = result;
for (i = 0; i < argc; i++) {
numChars = Tcl_ConvertElement(argv[i], dst,
@@ -922,7 +930,7 @@ Tcl_Merge(
}
if (flagPtr != localFlags) {
- ckfree((char *) flagPtr);
+ ckfree(flagPtr);
}
return result;
}
@@ -948,7 +956,7 @@ Tcl_Merge(
char
Tcl_Backslash(
- CONST char *src, /* Points to the backslash character of a
+ const char *src, /* Points to the backslash character of a
* backslash sequence. */
int *readPtr) /* Fill in with number of characters read from
* src, unless NULL. */
@@ -1122,7 +1130,7 @@ TclTrimLeft(
char *
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
- CONST char * CONST *argv) /* Array of strings to concatenate. */
+ const char *const *argv) /* Array of strings to concatenate. */
{
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
@@ -1210,7 +1218,7 @@ Tcl_Concat(
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
- Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */
+ Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
int i, elemLength, needSpace = 0, bytesNeeded = 0;
const char *element;
@@ -1344,8 +1352,8 @@ Tcl_ConcatObj(
int
Tcl_StringMatch(
- CONST char *str, /* String. */
- CONST char *pattern) /* Pattern, which may contain special
+ const char *str, /* String. */
+ const char *pattern) /* Pattern, which may contain special
* characters. */
{
return Tcl_StringCaseMatch(str, pattern, 0);
@@ -1372,13 +1380,13 @@ Tcl_StringMatch(
int
Tcl_StringCaseMatch(
- CONST char *str, /* String. */
- CONST char *pattern, /* Pattern, which may contain special
+ const char *str, /* String. */
+ const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
- CONST char *pstart = pattern;
+ const char *pstart = pattern;
Tcl_UniChar ch1, ch2;
while (1) {
@@ -1605,11 +1613,12 @@ Tcl_StringCaseMatch(
int
TclByteArrayMatch(
- const unsigned char *string, /* String. */
- int strLen, /* Length of String */
- const unsigned char *pattern, /* Pattern, which may contain special
- * characters. */
- int ptnLen, /* Length of Pattern */
+ const unsigned char *string,/* String. */
+ int strLen, /* Length of String */
+ const unsigned char *pattern,
+ /* Pattern, which may contain special
+ * characters. */
+ int ptnLen, /* Length of Pattern */
int flags)
{
const unsigned char *stringEnd, *patternEnd;
@@ -1780,9 +1789,10 @@ TclByteArrayMatch(
int
TclStringMatchObj(
- Tcl_Obj *strObj, /* string object. */
- Tcl_Obj *ptnObj, /* pattern object. */
- int flags) /* Only TCL_MATCH_NOCASE should be passed or 0. */
+ Tcl_Obj *strObj, /* string object. */
+ Tcl_Obj *ptnObj, /* pattern object. */
+ int flags) /* Only TCL_MATCH_NOCASE should be passed, or
+ * 0. */
{
int match, length, plen;
@@ -1793,13 +1803,13 @@ TclStringMatchObj(
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
- if ((strObj->typePtr == &tclStringType)) {
+ if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = Tcl_GetUnicodeFromObj(strObj, &length);
uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
- } else if ((strObj->typePtr == &tclByteArrayType) && !flags) {
+ } else if (TclIsPureByteArray(strObj) && !flags) {
unsigned char *data, *ptn;
data = Tcl_GetByteArrayFromObj(strObj, &length);
@@ -1861,15 +1871,13 @@ Tcl_DStringInit(
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
- CONST char *bytes, /* String to append. If length is -1 then this
+ const char *bytes, /* String to append. If length is -1 then this
* must be null-terminated. */
int length) /* Number of bytes from "bytes" to append. If
* < 0, then append all of bytes, up to null
* at end. */
{
int newSize;
- char *dst;
- CONST char *end;
if (length < 0) {
length = strlen(bytes);
@@ -1885,13 +1893,12 @@ Tcl_DStringAppend(
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
- char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+ char *newString = ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
dsPtr->string = newString;
} else {
- dsPtr->string = ckrealloc((void *) dsPtr->string,
- (size_t) dsPtr->spaceAvl);
+ dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
@@ -1899,12 +1906,9 @@ Tcl_DStringAppend(
* Copy the new string into the buffer at the end of the old one.
*/
- for (dst = dsPtr->string + dsPtr->length, end = bytes+length;
- bytes < end; bytes++, dst++) {
- *dst = *bytes;
- }
- *dst = '\0';
+ memcpy(dsPtr->string + dsPtr->length, bytes, length);
dsPtr->length += length;
+ dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
@@ -1929,7 +1933,7 @@ Tcl_DStringAppend(
char *
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
- CONST char *element) /* String to append. Must be
+ const char *element) /* String to append. Must be
* null-terminated. */
{
int newSize, flags, strSize;
@@ -1950,13 +1954,12 @@ Tcl_DStringAppendElement(
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
- char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+ char *newString = ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
dsPtr->string = newString;
} else {
- dsPtr->string = (char *) ckrealloc((void *) dsPtr->string,
- (size_t) dsPtr->spaceAvl);
+ dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
@@ -2032,13 +2035,12 @@ Tcl_DStringSetLength(
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
- char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+ char *newString = ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
dsPtr->string = newString;
} else {
- dsPtr->string = (char *) ckrealloc((void *) dsPtr->string,
- (size_t) dsPtr->spaceAvl);
+ dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
dsPtr->length = length;
@@ -2101,14 +2103,16 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
+ Interp *iPtr = (Interp *) interp;
+
Tcl_ResetResult(interp);
if (dsPtr->string != dsPtr->staticSpace) {
- interp->result = dsPtr->string;
- interp->freeProc = TCL_DYNAMIC;
+ iPtr->result = dsPtr->string;
+ iPtr->freeProc = TCL_DYNAMIC;
} else if (dsPtr->length < TCL_RESULT_SIZE) {
- interp->result = ((Interp *) interp)->resultSpace;
- strcpy(interp->result, dsPtr->string);
+ iPtr->result = iPtr->resultSpace;
+ memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1);
} else {
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
}
@@ -2164,9 +2168,9 @@ Tcl_DStringGetResult(
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
- dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
+ dsPtr->string = ckalloc(dsPtr->length+1);
memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1);
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
dsPtr->spaceAvl = dsPtr->length+1;
iPtr->freeProc = NULL;
@@ -2175,7 +2179,7 @@ Tcl_DStringGetResult(
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
- dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
+ dsPtr->string = ckalloc(dsPtr->length+1);
dsPtr->spaceAvl = dsPtr->length + 1;
}
memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1);
@@ -2271,63 +2275,62 @@ Tcl_PrintDouble(
char *p, c;
int exponent;
int signum;
- char* digits;
- char* end;
-
- int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int));
+ char *digits;
+ char *end;
+ int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int));
/*
- * Handle NaN.
- */
-
- if (TclIsNaN(value)) {
- TclFormatNaN(value, dst);
- return;
- }
-
- /*
- * Handle infinities.
- */
+ * Handle NaN.
+ */
+
+ if (TclIsNaN(value)) {
+ TclFormatNaN(value, dst);
+ return;
+ }
- if (TclIsInfinite(value)) {
+ /*
+ * Handle infinities.
+ */
+
+ if (TclIsInfinite(value)) {
/*
* Remember to copy the terminating NUL too.
*/
- if (value < 0) {
+ if (value < 0) {
memcpy(dst, "-Inf", 5);
- } else {
+ } else {
memcpy(dst, "Inf", 4);
- }
- return;
}
+ return;
+ }
- /*
- * Ordinary (normal and denormal) values.
- */
-
+ /*
+ * Ordinary (normal and denormal) values.
+ */
+
if (*precisionPtr == 0) {
digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
- &exponent, &signum, &end);
+ &exponent, &signum, &end);
} else {
/*
* There are at least two possible interpretations for tcl_precision.
*
* The first is, "choose the decimal representation having
- * $tcl_precision digits of significance that is nearest to the
- * given number, breaking ties by rounding to even, and then
- * trimming trailing zeros." This gives the greatest possible
- * precision in the decimal string, but offers the anomaly that
- * [expr 0.1] will be "0.10000000000000001".
+ * $tcl_precision digits of significance that is nearest to the given
+ * number, breaking ties by rounding to even, and then trimming
+ * trailing zeros." This gives the greatest possible precision in the
+ * decimal string, but offers the anomaly that [expr 0.1] will be
+ * "0.10000000000000001".
*
- * The second is "choose the decimal representation having at
- * most $tcl_precision digits of significance that is nearest
- * to the given number. If no such representation converts
- * exactly to the given number, choose the one that is closest,
- * breaking ties by rounding to even. If more than one such
- * representation converts exactly to the given number, choose
- * the shortest, breaking ties in favour of the nearest, breaking
- * remaining ties in favour of the one ending in an even digit."
+ * The second is "choose the decimal representation having at most
+ * $tcl_precision digits of significance that is nearest to the given
+ * number. If no such representation converts exactly to the given
+ * number, choose the one that is closest, breaking ties by rounding
+ * to even. If more than one such representation converts exactly to
+ * the given number, choose the shortest, breaking ties in favour of
+ * the nearest, breaking remaining ties in favour of the one ending in
+ * an even digit."
*
* Tcl 8.4 implements the first of these, which gives rise to
* anomalies in formatting:
@@ -2340,22 +2343,22 @@ Tcl_PrintDouble(
* 9.9999999999999995e-08
*
* For human readability, it appears better to choose the second rule,
- * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we
- * prefer the first (the recommended zero value for tcl_precision
- * avoids the problem entirely).
+ * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
+ * the first (the recommended zero value for tcl_precision avoids the
+ * problem entirely).
*
- * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the
- * method that allows floating point values to be shortened if
- * it can be done without loss of precision.
+ * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method
+ * that allows floating point values to be shortened if it can be done
+ * without loss of precision.
*/
digits = TclDoubleDigits(value, *precisionPtr,
TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */,
&exponent, &signum, &end);
}
- if (signum) {
- *dst++ = '-';
- }
+ if (signum) {
+ *dst++ = '-';
+ }
p = digits;
if (exponent < -4 || exponent > 16) {
/*
@@ -2371,10 +2374,12 @@ Tcl_PrintDouble(
c = *++p;
}
}
- /*
- * Tcl 8.4 appears to format with at least a two-digit exponent; \
+
+ /*
+ * Tcl 8.4 appears to format with at least a two-digit exponent;
* preserve that behaviour when tcl_precision != 0
*/
+
if (*precisionPtr == 0) {
sprintf(dst, "e%+d", exponent);
} else {
@@ -2439,11 +2444,11 @@ char *
TclPrecTraceProc(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter containing variable. */
- CONST char *name1, /* Name of variable. */
- CONST char *name2, /* Second part of variable name. */
+ const char *name1, /* Name of variable. */
+ const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
- Tcl_Obj* value;
+ Tcl_Obj *value;
int prec;
int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int));
@@ -2480,13 +2485,13 @@ TclPrecTraceProc(
*/
if (Tcl_IsSafe(interp)) {
- return "can't modify precision from a safe interpreter";
+ return (char *) "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL
- || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK
+ || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK
|| prec < 0 || prec > TCL_MAX_PREC) {
- return "improper value for precision";
+ return (char *) "improper value for precision";
}
*precisionPtr = prec;
return NULL;
@@ -2511,8 +2516,8 @@ TclPrecTraceProc(
int
TclNeedSpace(
- CONST char *start, /* First character in string. */
- CONST char *end) /* End of string (place where space will be
+ const char *start, /* First character in string. */
+ const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
@@ -2562,6 +2567,7 @@ TclNeedSpace(
* NOTE: Remove this if other Unicode spaces ever get accepted as
* list-element separators.
*/
+
return 1;
}
switch (*end) {
@@ -2586,19 +2592,19 @@ TclNeedSpace(
* This procedure formats an integer into a sequence of decimal digit
* characters in a buffer. If the integer is negative, a minus sign is
* inserted at the start of the buffer. A null character is inserted at
- * the end of the formatted characters. It is the caller's
- * responsibility to ensure that enough storage is available. This
- * procedure has the effect of sprintf(buffer, "%ld", n) but is faster
- * as proven in benchmarks. This is key to UpdateStringOfInt, which
- * is a common path for a lot of code (e.g. int-indexed arrays).
+ * the end of the formatted characters. It is the caller's responsibility
+ * to ensure that enough storage is available. This procedure has the
+ * effect of sprintf(buffer, "%ld", n) but is faster as proven in
+ * benchmarks. This is key to UpdateStringOfInt, which is a common path
+ * for a lot of code (e.g. int-indexed arrays).
*
* Results:
* An integer representing the number of characters formatted, not
* including the terminating \0.
*
* Side effects:
- * The formatted characters are written into the storage pointer to
- * by the "buffer" argument.
+ * The formatted characters are written into the storage pointer to by
+ * the "buffer" argument.
*
*----------------------------------------------------------------------
*/
@@ -2612,7 +2618,7 @@ TclFormatInt(buffer, n)
long intVal;
int i;
int numFormatted, j;
- char *digits = "0123456789";
+ const char *digits = "0123456789";
/*
* Check first whether "n" is zero.
@@ -2701,7 +2707,8 @@ TclGetIntForIndex(
* representing an index. */
{
int length;
- char *opPtr, *bytes;
+ char *opPtr;
+ const char *bytes;
if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
@@ -2762,14 +2769,13 @@ TclGetIntForIndex(
parseError:
if (interp != NULL) {
- char *bytes = Tcl_GetString(objPtr);
-
/*
* The result might not be empty; this resets it which should be both
* a cheap operation, and of little problem because this is an
* error-generation path anyway.
*/
+ bytes = Tcl_GetString(objPtr);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad index \"", bytes,
"\": must be integer?[+-]integer? or end?[+-]integer?", NULL);
@@ -2777,6 +2783,7 @@ TclGetIntForIndex(
bytes += 4;
}
TclCheckBadOctal(interp, bytes);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
@@ -2804,12 +2811,12 @@ TclGetIntForIndex(
static void
UpdateStringOfEndOffset(
- register Tcl_Obj* objPtr)
+ register Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
register int len;
- strcpy(buffer, "end");
+ memcpy(buffer, "end", sizeof("end") + 1);
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
@@ -2844,7 +2851,7 @@ SetEndOffsetFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to parse */
{
int offset; /* Offset in the "end-offset" expression */
- register char* bytes; /* String rep of the object */
+ register const char *bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
/*
@@ -2866,6 +2873,7 @@ SetEndOffsetFromAny(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad index \"", bytes,
"\": must be end?[+-]integer?", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
@@ -2883,7 +2891,7 @@ SetEndOffsetFromAny(
*/
if (isspace(UCHAR(bytes[4]))) {
- return TCL_ERROR;
+ goto badIndexFormat;
}
if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
return TCL_ERROR;
@@ -2896,10 +2904,12 @@ SetEndOffsetFromAny(
* Conversion failed. Report the error.
*/
+ badIndexFormat:
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad index \"", bytes,
"\": must be end?[+-]integer?", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
@@ -2938,9 +2948,9 @@ TclCheckBadOctal(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
- CONST char *value) /* String to check. */
+ const char *value) /* String to check. */
{
- register CONST char *p = value;
+ register const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted leading
@@ -2955,7 +2965,7 @@ TclCheckBadOctal(
}
if (*p == '0') {
if ((p[1] == 'o') || p[1] == 'O') {
- p+=2;
+ p += 2;
}
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
@@ -3002,7 +3012,8 @@ ClearHash(
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr);
+
Tcl_DecrRefCount(objPtr);
Tcl_DeleteHashEntry(hPtr);
}
@@ -3030,12 +3041,12 @@ static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
- Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
- Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *));
+ Tcl_HashTable **tablePtrPtr =
+ Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
- *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
- Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr);
+ *tablePtrPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
@@ -3059,11 +3070,11 @@ static void
FreeThreadHash(
ClientData clientData)
{
- Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
+ Tcl_HashTable *tablePtr = clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
- ckfree((char *) tablePtr);
+ ckfree(tablePtr);
}
/*
@@ -3081,7 +3092,7 @@ static void
FreeProcessGlobalValue(
ClientData clientData)
{
- ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
+ ProcessGlobalValue *pgvPtr = clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
@@ -3111,7 +3122,7 @@ TclSetProcessGlobalValue(
Tcl_Obj *newValue,
Tcl_Encoding encoding)
{
- CONST char *bytes;
+ const char *bytes;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int dummy;
@@ -3129,7 +3140,7 @@ TclSetProcessGlobalValue(
Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
}
bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
- pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1);
+ pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
@@ -3145,9 +3156,8 @@ TclSetProcessGlobalValue(
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
- hPtr = Tcl_CreateHashEntry(cacheMap,
- (char *) INT2PTR(pgvPtr->epoch), &dummy);
- Tcl_SetHashValue(hPtr, (ClientData) newValue);
+ hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
+ Tcl_SetHashValue(hPtr, newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
@@ -3195,8 +3205,7 @@ TclGetProcessGlobalValue(
Tcl_DStringLength(&native), &newValue);
Tcl_DStringFree(&native);
ckfree(pgvPtr->value);
- pgvPtr->value = ckalloc((unsigned int)
- Tcl_DStringLength(&newValue) + 1);
+ pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
(size_t) Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
@@ -3228,12 +3237,11 @@ TclGetProcessGlobalValue(
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
- (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
- &pgvPtr->encoding);
+ pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding);
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
- Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData)pgvPtr);
+ Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
/*
@@ -3242,12 +3250,12 @@ TclGetProcessGlobalValue(
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
- (char *) INT2PTR(pgvPtr->epoch), &dummy);
+ INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
- Tcl_SetHashValue(hPtr, (ClientData) value);
+ Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
- return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ return Tcl_GetHashValue(hPtr);
}
/*
@@ -3259,7 +3267,7 @@ TclGetProcessGlobalValue(
* (normally as computed by TclpFindExecutable).
*
* Results:
- * None.
+ * None.
*
* Side effects:
* Stores the executable name.
@@ -3290,7 +3298,7 @@ TclSetObjNameOfExecutable(
* pathname of the application is unknown.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -3309,20 +3317,20 @@ TclGetObjNameOfExecutable(void)
* This function retrieves the absolute pathname of the application in
* which the Tcl library is running, and returns it in string form.
*
- * The returned string belongs to Tcl and should be copied if the caller
- * plans to keep it, to guard against it becoming invalid.
+ * The returned string belongs to Tcl and should be copied if the caller
+ * plans to keep it, to guard against it becoming invalid.
*
* Results:
* A pointer to the internal string or NULL if the internal full path
* name has not been computed or unknown.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_GetNameOfExecutable(void)
{
int numBytes;
@@ -3412,8 +3420,8 @@ TclReToGlob(
int *exactPtr)
{
int anchorLeft, anchorRight, lastIsStar, numStars;
- char *dsStr, *dsStrStart, *msg;
- const char *p, *strEnd;
+ char *dsStr, *dsStrStart;
+ const char *msg, *p, *strEnd, *code;
strEnd = reStr + reStrLen;
Tcl_DStringInit(dsPtr);
@@ -3424,10 +3432,11 @@ TclReToGlob(
if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
/*
- * At most, the glob pattern has length 2*reStrLen + 2 to
- * backslash escape every character and have * at each end.
+ * At most, the glob pattern has length 2*reStrLen + 2 to backslash
+ * escape every character and have * at each end.
*/
- Tcl_DStringSetLength(dsPtr, 2*reStrLen + 2);
+
+ Tcl_DStringSetLength(dsPtr, reStrLen + 2);
dsStr = dsStrStart = Tcl_DStringValue(dsPtr);
*dsStr++ = '*';
for (p = reStr + 4; p < strEnd; p++) {
@@ -3450,8 +3459,8 @@ TclReToGlob(
}
/*
- * At most, the glob pattern has length reStrLen + 2 to account
- * for possible * at each end.
+ * At most, the glob pattern has length reStrLen + 2 to account for
+ * possible * at each end.
*/
Tcl_DStringSetLength(dsPtr, reStrLen + 2);
@@ -3461,12 +3470,12 @@ TclReToGlob(
* Check for anchored REs (ie ^foo$), so we can use string equal if
* possible. Do not alter the start of str so we can free it correctly.
*
- * Keep track of the last char being an unescaped star to prevent
- * multiple instances. Simpler than checking that the last star
- * may be escaped.
+ * Keep track of the last char being an unescaped star to prevent multiple
+ * instances. Simpler than checking that the last star may be escaped.
*/
msg = NULL;
+ code = NULL;
p = reStr;
anchorRight = 0;
lastIsStar = 0;
@@ -3523,6 +3532,7 @@ TclReToGlob(
break;
default:
msg = "invalid escape sequence";
+ code = "BADESCAPE";
goto invalidGlob;
}
break;
@@ -3551,6 +3561,7 @@ TclReToGlob(
case '$':
if (p+1 != strEnd) {
msg = "$ not anchor";
+ code = "NONANCHOR";
goto invalidGlob;
}
anchorRight = 1;
@@ -3558,8 +3569,8 @@ TclReToGlob(
case '*': case '+': case '?': case '|': case '^':
case '{': case '}': case '(': case ')': case '[': case ']':
msg = "unhandled RE special char";
+ code = "UNHANDLED";
goto invalidGlob;
- break;
default:
*dsStr++ = *p;
break;
@@ -3571,7 +3582,9 @@ TclReToGlob(
* Heuristic: if >1 non-anchoring *, the risk is large that glob
* matching is slower than the RE engine, so report invalid.
*/
+
msg = "excessive recursive glob backtrack potential";
+ code = "OVERCOMPLEX";
goto invalidGlob;
}
@@ -3600,6 +3613,7 @@ TclReToGlob(
#endif
if (interp != NULL) {
Tcl_AppendResult(interp, msg, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index aaf1cb9..55c031c 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -26,12 +26,11 @@
static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static void FreeVarEntry(Tcl_HashEntry *hPtr);
static int CompareVarKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashVarKey(Tcl_HashTable *tablePtr, void *keyPtr);
-static Tcl_HashKeyType tclVarHashKeyType = {
+static const Tcl_HashKeyType tclVarHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
- HashVarKey, /* hashKeyProc */
+ TclHashObjKey, /* hashKeyProc */
CompareVarKeys, /* compareKeysProc */
AllocVarEntry, /* allocEntryProc */
FreeVarEntry /* freeEntryProc */
@@ -53,8 +52,8 @@ VarHashCreateVar(
Tcl_Obj *key,
int *newPtr)
{
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
- (char *) key, newPtr);
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
+ key, newPtr);
if (hPtr) {
return VarHashGetValue(hPtr);
@@ -65,13 +64,15 @@ VarHashCreateVar(
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
+
#define VarHashInvalidateEntry(varPtr) \
((varPtr)->flags |= VAR_DEAD_HASH)
+
#define VarHashDeleteEntry(varPtr) \
Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))
#define VarHashFirstEntry(tablePtr, searchPtr) \
- Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr))
+ Tcl_FirstHashEntry(&(tablePtr)->table, (searchPtr))
#define VarHashNextEntry(searchPtr) \
Tcl_NextHashEntry((searchPtr))
@@ -107,7 +108,7 @@ VarHashNextVar(
(((VarInHash *)(varPtr))->entry.key.objPtr)
#define VarHashDeleteTable(tablePtr) \
- Tcl_DeleteHashTable((Tcl_HashTable *) (tablePtr))
+ Tcl_DeleteHashTable(&(tablePtr)->table)
/*
* The strings below are used to indicate what went wrong when a variable
@@ -142,8 +143,8 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *patternPtr, int includeLinks);
static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
- Var *varPtr, int flags);
-static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp,
+ Var *varPtr, int flags, int index);
+static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp,
Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
int flags);
static int ObjMakeUpvar(Tcl_Interp *interp,
@@ -154,7 +155,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
Tcl_Obj *varNamePtr, Tcl_Obj *handleObj);
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
- Tcl_Obj *part2Ptr, int flags);
+ Tcl_Obj *part2Ptr, int flags, int index);
static int SetArraySearchObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
@@ -183,7 +184,7 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
*
* localVarName - INTERNALREP DEFINITION:
* ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache
- * or NULL if it is this same obj
+ * or NULL if it is this same obj
* ptrAndLongRep.value: index into locals table
*
* nsVarName - INTERNALREP DEFINITION:
@@ -197,7 +198,7 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
* Tcl_Obj), or NULL if it is a scalar variable
*/
-static Tcl_ObjType localVarNameType = {
+static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
};
@@ -215,13 +216,13 @@ static Tcl_ObjType localVarNameType = {
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;
-static Tcl_ObjType tclNsVarNameType = {
+static const Tcl_ObjType tclNsVarNameType = {
"namespaceVarName",
FreeNsVarName, DupNsVarName, PanicOnUpdateVarName, PanicOnSetVarName
};
#endif
-static Tcl_ObjType tclParsedVarNameType = {
+static const Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
};
@@ -238,7 +239,7 @@ static Tcl_ObjType tclParsedVarNameType = {
* as this can be safely copied.
*/
-Tcl_ObjType tclArraySearchType = {
+const Tcl_ObjType tclArraySearchType = {
"array search",
NULL, NULL, NULL, SetArraySearchObj
};
@@ -293,7 +294,7 @@ CleanupVar(
&& !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
- ckfree((char *) varPtr);
+ ckfree(varPtr);
} else {
VarHashDeleteEntry(varPtr);
}
@@ -302,7 +303,7 @@ CleanupVar(
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
(VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
- ckfree((char *) arrayPtr);
+ ckfree(arrayPtr);
} else {
VarHashDeleteEntry(arrayPtr);
}
@@ -505,7 +506,7 @@ TclObjLookupVarEx(
Interp *iPtr = (Interp *) interp;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
- char *part1;
+ const char *part1;
int index, len1, len2;
int parsed = 0;
Tcl_Obj *objPtr;
@@ -515,7 +516,7 @@ TclObjLookupVarEx(
#if ENABLE_NS_VARNAME_CACHING
Namespace *nsPtr;
#endif
- char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
+ const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
char *newPart2 = NULL;
*arrayPtrPtr = NULL;
@@ -545,8 +546,7 @@ TclObjLookupVarEx(
* Use the cached index if the names coincide.
*/
- Tcl_Obj *namePtr = (Tcl_Obj *)
- part1Ptr->internalRep.ptrAndLongRep.ptr;
+ Tcl_Obj *namePtr = part1Ptr->internalRep.ptrAndLongRep.ptr;
Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
@@ -612,6 +612,7 @@ TclObjLookupVarEx(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
noSuchVar, -1);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL);
}
return NULL;
}
@@ -644,6 +645,8 @@ TclObjLookupVarEx(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME",
+ NULL);
}
return NULL;
}
@@ -657,8 +660,8 @@ TclObjLookupVarEx(
len2 = len1 - i - 2;
len1 = i;
- newPart2 = ckalloc((unsigned int) (len2+1));
- memcpy(newPart2, part2, (unsigned int) len2);
+ newPart2 = ckalloc(len2 + 1);
+ memcpy(newPart2, part2, (unsigned) len2);
*(newPart2+len2) = '\0';
part2 = newPart2;
part2Ptr = Tcl_NewStringObj(newPart2, -1);
@@ -700,13 +703,14 @@ TclObjLookupVarEx(
*/
TclFreeIntRep(part1Ptr);
- part1Ptr->typePtr = NULL;
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(part1Ptr), NULL);
}
if (newPart2) {
Tcl_DecrRefCount(part2Ptr);
@@ -763,7 +767,9 @@ TclObjLookupVarEx(
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
- "Cached variable reference is NULL.", -1);
+ "cached variable reference is NULL.", -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(part1Ptr), NULL);
}
return NULL;
}
@@ -871,8 +877,8 @@ TclLookupSimpleVar(
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
- int isNew, i, result;
- const char *varName = TclGetString(varNamePtr);
+ int isNew, i, result, varLen;
+ const char *varName = TclGetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */
@@ -894,7 +900,7 @@ TclLookupSimpleVar(
&& !(flags & AVOID_RESOLVERS)) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
- result = (*cxtNsPtr->varResProc)(interp, varName,
+ result = cxtNsPtr->varResProc(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
@@ -902,7 +908,7 @@ TclLookupSimpleVar(
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
- result = (*resPtr->varResProc)(interp, varName,
+ result = resPtr->varResProc(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
@@ -997,17 +1003,18 @@ TclLookupSimpleVar(
}
}
} else { /* Local var: look in frame varFramePtr. */
- int localCt = varFramePtr->numCompiledLocals;
+ int localLen, localCt = varFramePtr->numCompiledLocals;
Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
+ const char *localNameStr;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
register Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
- char *localName = TclGetString(objPtr);
+ localNameStr = TclGetStringFromObj(objPtr, &localLen);
- if ((varName[0] == localName[0])
- && (strcmp(varName, localName) == 0)) {
+ if ((varLen == localLen) && (varName[0] == localNameStr[0])
+ && !memcmp(varName, localNameStr, varLen)) {
*indexPtr = i;
return (Var *) &varFramePtr->compiledLocals[i];
}
@@ -1016,8 +1023,7 @@ TclLookupSimpleVar(
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
- tablePtr = (TclVarHashTable *)
- ckalloc(sizeof(TclVarHashTable));
+ tablePtr = ckalloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
@@ -1107,6 +1113,8 @@ TclLookupArrayElement(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
noSuchVar, index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
}
return NULL;
}
@@ -1120,12 +1128,14 @@ TclLookupArrayElement(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
danglingVar, index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
}
return NULL;
}
TclSetVarArray(arrayPtr);
- tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable));
+ tablePtr = ckalloc(sizeof(TclVarHashTable));
arrayPtr->value.tablePtr = tablePtr;
if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
@@ -1138,6 +1148,8 @@ TclLookupArrayElement(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray,
index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
}
return NULL;
}
@@ -1196,7 +1208,17 @@ Tcl_GetVar(
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
- return Tcl_GetVar2(interp, varName, NULL, flags);
+ Tcl_Obj *varNamePtr, *resultPtr;
+
+ varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(varNamePtr);
+ resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
+ TclDecrRefCount(varNamePtr);
+
+ if (resultPtr == NULL) {
+ return NULL;
+ }
+ return TclGetString(resultPtr);
}
/*
@@ -1234,13 +1256,27 @@ Tcl_GetVar2(
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
* bits. */
{
- Tcl_Obj *objPtr;
+ Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
+
+ 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);
- objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
- if (objPtr == NULL) {
+ Tcl_DecrRefCount(part1Ptr);
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
+ if (resultPtr == NULL) {
return NULL;
}
- return TclGetString(objPtr);
+ return TclGetString(resultPtr);
}
/*
@@ -1433,6 +1469,7 @@ TclPtrGetVar(
*/
errorReturn:
+ Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", NULL);
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
}
@@ -1522,7 +1559,21 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- return Tcl_SetVar2(interp, varName, NULL, newValue, flags);
+ Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
+
+ varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(varNamePtr);
+ valuePtr = Tcl_NewStringObj(newValue, -1);
+ Tcl_IncrRefCount(valuePtr);
+
+ varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
+
+ Tcl_DecrRefCount(varNamePtr);
+ Tcl_DecrRefCount(valuePtr);
+ if (varValuePtr == NULL) {
+ return NULL;
+ }
+ return TclGetString(varValuePtr);
}
/*
@@ -1566,19 +1617,27 @@ Tcl_SetVar2(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
- register Tcl_Obj *valuePtr;
+ Tcl_Obj *valuePtr, *part1Ptr, *part2Ptr;
Tcl_Obj *varValuePtr;
- /*
- * Create an object holding the variable's new value and use Tcl_SetVar2Ex
- * to actually set the variable.
- */
-
+ 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_SetVar2Ex(interp, part1, part2, valuePtr, flags);
- Tcl_DecrRefCount(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;
}
@@ -1781,9 +1840,11 @@ TclPtrSetVar(
if (TclIsVarArrayElement(varPtr)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
danglingElement, index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL);
} else {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
danglingVar, index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL);
}
}
goto earlyError;
@@ -1796,6 +1857,7 @@ TclPtrSetVar(
if (TclIsVarArray(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray,index);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
}
goto earlyError;
}
@@ -1805,7 +1867,7 @@ TclPtrSetVar(
* requested. This was done for INST_LAPPEND_* but that was inconsistent
* with the non-bc instruction, and would cause failures trying to
* lappend to any non-existing ::env var, which is inconsistent with
- * documented behavior. [Bug #3057639]
+ * documented behavior. [Bug #3057639].
*/
if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ)
@@ -1868,12 +1930,7 @@ TclPtrSetVar(
if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
- /*
- * TIP #280.
- * Ensure that the continuation line data for the string
- * is not lost and applies to the extended script as well.
- */
- TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr);
+ TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
@@ -1931,6 +1988,9 @@ TclPtrSetVar(
*/
cleanup:
+ if (resultPtr == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", NULL);
+ }
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
}
@@ -2108,7 +2168,21 @@ Tcl_UnsetVar(
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
* TCL_LEAVE_ERR_MSG. */
{
- return Tcl_UnsetVar2(interp, varName, NULL, flags);
+ int result;
+ Tcl_Obj *varNamePtr;
+
+ varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(varNamePtr);
+
+ /*
+ * Filter to pass through only the flags this interface supports.
+ */
+
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
+ result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags);
+
+ Tcl_DecrRefCount(varNamePtr);
+ return result;
}
/*
@@ -2197,10 +2271,7 @@ TclObjUnsetVar2(
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
- Var *varPtr;
- Interp *iPtr = (Interp *) interp;
- Var *arrayPtr;
- int result;
+ Var *varPtr, *arrayPtr;
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
@@ -2208,7 +2279,52 @@ TclObjUnsetVar2(
return TCL_ERROR;
}
- result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
+ return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags,
+ -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrUnsetVar --
+ *
+ * Delete a variable, given the pointers to the variable's (and possibly
+ * containing array's) VAR structure.
+ *
+ * Results:
+ * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
+ * the variable can't be unset. In the event of an error, if the
+ * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
+ * interp's result.
+ *
+ * Side effects:
+ * If varPtr and arrayPtr indicate a local or global variable in interp,
+ * it is deleted. If varPtr is an array reference and part2Ptr is NULL,
+ * then the whole array is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPtrUnsetVar(
+ Tcl_Interp *interp, /* Command interpreter in which varName is to
+ * be looked up. */
+ register Var *varPtr, /* The variable to be unset. */
+ Var *arrayPtr, /* NULL for scalar variables, pointer to the
+ * containing array otherwise. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ const int flags, /* OR-ed combination of any of
+ * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_LEAVE_ERR_MSG. */
+ int index) /* Index into the local variable table of the
+ * variable, or -1. Only used when part1Ptr is
+ * NULL. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
/*
* Keep the variable alive until we're done with it. We used to
@@ -2221,7 +2337,7 @@ TclObjUnsetVar2(
VarHashRefCount(varPtr)++;
}
- UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags);
+ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index);
/*
* It's an error to unset an undefined variable.
@@ -2230,7 +2346,8 @@ TclObjUnsetVar2(
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
- ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1);
+ ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index);
+ Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL);
}
}
@@ -2243,7 +2360,6 @@ TclObjUnsetVar2(
if (part1Ptr->typePtr == &tclNsVarNameType) {
TclFreeIntRep(part1Ptr);
- part1Ptr->typePtr = NULL;
}
#endif
@@ -2286,7 +2402,8 @@ UnsetVarStruct(
Interp *iPtr,
Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr,
- int flags)
+ int flags,
+ int index)
{
Var dummyVar;
int traced = TclIsVarTraced(varPtr)
@@ -2326,7 +2443,7 @@ UnsetVarStruct(
if (traced) {
VarTrace *tracePtr = NULL;
- Tcl_HashEntry *tPtr = NULL;
+ Tcl_HashEntry *tPtr;
if (TclIsVarTraced(&dummyVar)) {
/*
@@ -2335,18 +2452,15 @@ UnsetVarStruct(
*/
int isNew;
- Tcl_HashEntry *tPtr =
- Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
+ tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
tracePtr = Tcl_GetHashValue(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
Tcl_DeleteHashEntry(tPtr);
if (dummyVar.flags & VAR_TRACED_UNSET) {
tPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
- (char *) &dummyVar, &isNew);
+ &dummyVar, &isNew);
Tcl_SetHashValue(tPtr, tracePtr);
- } else {
- tPtr = NULL;
}
}
@@ -2356,21 +2470,20 @@ UnsetVarStruct(
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS,
- /* leaveErrMsg */ 0, -1);
+ /* leaveErrMsg */ 0, index);
/*
* The traces that we just called may have triggered a change in
- * the set of traces. [Bug 2629338]
+ * the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
- tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) &dummyVar);
+ tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
tracePtr = Tcl_GetHashValue(tPtr);
- }
-
- if (tPtr) {
- Tcl_DeleteHashEntry(tPtr);
+ if (tPtr) {
+ Tcl_DeleteHashEntry(tPtr);
+ }
}
}
@@ -2382,7 +2495,7 @@ UnsetVarStruct(
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
- Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
@@ -2412,7 +2525,8 @@ UnsetVarStruct(
*/
DeleteArray(iPtr, part1Ptr, (Var *) &dummyVar, (flags
- & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
+ & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS,
+ index);
} else if (TclIsVarLink(&dummyVar)) {
/*
* For global/upvar variables referenced in procedures, decrement the
@@ -2462,7 +2576,7 @@ Tcl_UnsetObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
register int i, flags = TCL_LEAVE_ERR_MSG;
- register char *name;
+ register const char *name;
if (objc == 1) {
/*
@@ -2535,7 +2649,7 @@ Tcl_AppendObjCmd(
int i;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
@@ -2601,7 +2715,7 @@ Tcl_LappendObjCmd(
int result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
if (objc == 2) {
@@ -2714,66 +2828,315 @@ Tcl_LappendObjCmd(
/*
*----------------------------------------------------------------------
*
- * Tcl_ArrayObjCmd --
+ * TclArraySet --
*
- * This object-based function is invoked to process the "array" Tcl
- * command. See the user documentation for details on what it does.
+ * Set the elements of an array. If there are no elements to set, create
+ * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the
+ * TclSetupEnv routine.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
- * See the user documentation.
+ * A variable will be created if one does not already exist.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_ArrayObjCmd(
- ClientData dummy, /* Not used. */
+TclArraySet(
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *arrayNameObj, /* The array name. */
+ Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is
+ * NULL, create an empty array. */
{
+ Var *varPtr, *arrayPtr;
+ int result, i;
+
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (arrayPtr) {
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(arrayNameObj), NULL);
+ return TCL_ERROR;
+ }
+
+ if (arrayElemObj == NULL) {
+ goto ensureArray;
+ }
+
/*
- * The list of constants below should match the arrayOptions string array
- * below.
+ * Install the contents of the dictionary or list into the array.
*/
- enum {
- ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET,
- ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
- ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET
- };
- static const char *arrayOptions[] = {
- "anymore", "donesearch", "exists", "get", "names", "nextelement",
- "set", "size", "startsearch", "statistics", "unset", NULL
- };
+ if (arrayElemObj->typePtr == &tclDictType) {
+ Tcl_Obj *keyPtr, *valuePtr;
+ Tcl_DictSearch search;
+ int done;
+ if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (done == 0) {
+ /*
+ * Empty, so we'll just force the array to be properly existing
+ * instead.
+ */
+
+ goto ensureArray;
+ }
+
+ /*
+ * Don't need to look at result of Tcl_DictObjFirst as we've just
+ * successfully used a dictionary operation on the same object.
+ */
+
+ for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
+ &keyPtr, &valuePtr, &done) ; !done ;
+ Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
+ /*
+ * At this point, it would be nice if the key was directly usable
+ * by the array. This isn't the case though.
+ */
+
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+ if ((elemVarPtr == NULL) ||
+ (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
+ keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+ } else {
+ /*
+ * Not a dictionary, so assume (and convert to, for backward-
+ * -compatability reasons) a list.
+ */
+
+ int elemLen;
+ Tcl_Obj **elemPtrs, *copyListObj;
+
+ result = TclListObjGetElements(interp, arrayElemObj,
+ &elemLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (elemLen & 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list must have an even number of elements", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
+ return TCL_ERROR;
+ }
+ if (elemLen == 0) {
+ goto ensureArray;
+ }
+
+ /*
+ * We needn't worry about traces invalidating arrayPtr: should that be
+ * the case, TclPtrSetVar will return NULL so that we break out of the
+ * loop and return an error.
+ */
+
+ copyListObj = TclListObjCopy(NULL, arrayElemObj);
+ for (i=0 ; i<elemLen ; i+=2) {
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+ if ((elemVarPtr == NULL) ||
+ (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
+ elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ Tcl_DecrRefCount(copyListObj);
+ return result;
+ }
+
+ /*
+ * The list is empty make sure we have an array, or create one if
+ * necessary.
+ */
+
+ ensureArray:
+ if (varPtr != NULL) {
+ if (TclIsVarArray(varPtr)) {
+ /*
+ * Already an array, done.
+ */
+
+ return TCL_OK;
+ }
+ if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+ /*
+ * Either an array element, or a scalar: lose!
+ */
+
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
+ needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ return TCL_ERROR;
+ }
+ }
+ TclSetVarArray(varPtr);
+ varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayStartSearchCmd --
+ *
+ * This object-based function is invoked to process the "array
+ * startsearch" Tcl command. See the user documentation for details on
+ * what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArrayStartSearchCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
- Tcl_Obj *varNamePtr;
- int notArray;
- int index, result;
+ Tcl_Obj *varNameObj;
+ int isNew;
+ ArraySearch *searchPtr;
+ const char *varName;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
return TCL_ERROR;
}
+ varNameObj = objv[1];
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ varName = TclGetString(varNameObj);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ }
- if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
- 0, &index) != TCL_OK) {
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
return TCL_ERROR;
}
/*
- * Locate the array variable
+ * Make a new array search with a free name.
+ */
+
+ searchPtr = ckalloc(sizeof(ArraySearch));
+ hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+ if (isNew) {
+ searchPtr->id = 1;
+ Tcl_AppendResult(interp, "s-1-", varName, NULL);
+ varPtr->flags |= VAR_SEARCH_ACTIVE;
+ searchPtr->nextPtr = NULL;
+ } else {
+ char string[TCL_INTEGER_SPACE];
+
+ searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+ TclFormatInt(string, searchPtr->id);
+ Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
+ searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+ }
+ searchPtr->varPtr = varPtr;
+ searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+ &searchPtr->search);
+ Tcl_SetHashValue(hPtr, searchPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayAnyMoreCmd --
+ *
+ * This object-based function is invoked to process the "array anymore"
+ * Tcl command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArrayAnyMoreCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *varNameObj, *searchObj;
+ int gotValue;
+ ArraySearch *searchPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
+ return TCL_ERROR;
+ }
+ varNameObj = objv[1];
+ searchObj = objv[2];
+
+ /*
+ * Locate the array variable.
*/
- varNamePtr = objv[2];
- varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0,
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
/*
@@ -2783,7 +3146,7 @@ Tcl_ArrayObjCmd(
if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNamePtr, NULL,
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
@@ -2796,682 +3159,1088 @@ Tcl_ArrayObjCmd(
* traces.
*/
- notArray = 0;
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- notArray = 1;
+ Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
+ "\" isn't an array", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
+ TclGetString(varNameObj), NULL);
+ return TCL_ERROR;
}
- switch (index) {
- case ARRAY_ANYMORE: {
- ArraySearch *searchPtr;
+ /*
+ * Get the search.
+ */
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- while (1) {
- Var *varPtr2;
+ searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
- if (searchPtr->nextEntry != NULL) {
- varPtr2 = VarHashGetValue(searchPtr->nextEntry);
- if (!TclIsVarUndefined(varPtr2)) {
- break;
- }
- }
- searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
- if (searchPtr->nextEntry == NULL) {
- Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]);
- return TCL_OK;
+ /*
+ * Scan forward to find if there are any further elements in the array
+ * that are defined.
+ */
+
+ while (1) {
+ if (searchPtr->nextEntry != NULL) {
+ varPtr = VarHashGetValue(searchPtr->nextEntry);
+ if (!TclIsVarUndefined(varPtr)) {
+ gotValue = 1;
+ break;
}
}
- Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]);
- break;
+ searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
+ if (searchPtr->nextEntry == NULL) {
+ gotValue = 0;
+ break;
+ }
}
- case ARRAY_DONESEARCH: {
- ArraySearch *searchPtr, *prevPtr;
+ Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayNextElementCmd --
+ *
+ * This object-based function is invoked to process the "array
+ * nextelement" Tcl command. See the user documentation for details on
+ * what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
- if (searchPtr == NULL) {
+ /* ARGSUSED */
+static int
+ArrayNextElementCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *varNameObj, *searchObj;
+ ArraySearch *searchPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
+ return TCL_ERROR;
+ }
+ varNameObj = objv[1];
+ searchObj = objv[2];
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- hPtr = Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr);
- if (searchPtr == Tcl_GetHashValue(hPtr)) {
- if (searchPtr->nextPtr) {
- Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
- } else {
- varPtr->flags &= ~VAR_SEARCH_ACTIVE;
- Tcl_DeleteHashEntry(hPtr);
+ }
+
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
+ "\" isn't an array", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
+ TclGetString(varNameObj), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the search.
+ */
+
+ searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the next element from the search, or the empty string on
+ * exhaustion. Note that the [array anymore] command may well have already
+ * pulled a value from the hash enumeration, so we have to check the cache
+ * there first.
+ */
+
+ while (1) {
+ Tcl_HashEntry *hPtr = searchPtr->nextEntry;
+
+ if (hPtr == NULL) {
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ return TCL_OK;
}
} else {
- for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
- }
- }
+ searchPtr->nextEntry = NULL;
+ }
+ varPtr = VarHashGetValue(hPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ Tcl_SetObjResult(interp, VarHashGetKey(varPtr));
+ return TCL_OK;
}
- ckfree((char *) searchPtr);
- break;
}
- case ARRAY_NEXTELEMENT: {
- ArraySearch *searchPtr;
- Tcl_HashEntry *hPtr;
- Var *varPtr2;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayDoneSearchCmd --
+ *
+ * This object-based function is invoked to process the "array
+ * donesearch" Tcl command. See the user documentation for details on
+ * what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
+ /* ARGSUSED */
+static int
+ArrayDoneSearchCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *varNameObj, *searchObj;
+ ArraySearch *searchPtr, *prevPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
+ return TCL_ERROR;
+ }
+ varNameObj = objv[1];
+ searchObj = objv[2];
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- if (notArray) {
- goto error;
- }
- searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
- if (searchPtr == NULL) {
- return TCL_ERROR;
+ }
+
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
+ "\" isn't an array", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
+ TclGetString(varNameObj), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the search.
+ */
+
+ searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Unhook the search from the list of searches associated with the
+ * variable.
+ */
+
+ hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+ if (searchPtr == Tcl_GetHashValue(hPtr)) {
+ if (searchPtr->nextPtr) {
+ Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+ } else {
+ varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(hPtr);
}
- while (1) {
- hPtr = searchPtr->nextEntry;
- if (hPtr == NULL) {
- hPtr = Tcl_NextHashEntry(&searchPtr->search);
- if (hPtr == NULL) {
- return TCL_OK;
- }
- } else {
- searchPtr->nextEntry = NULL;
- }
- varPtr2 = VarHashGetValue(hPtr);
- if (!TclIsVarUndefined(varPtr2)) {
+ } else {
+ for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
break;
}
}
- Tcl_SetObjResult(interp, VarHashGetKey(varPtr2));
- break;
}
- case ARRAY_STARTSEARCH: {
- ArraySearch *searchPtr;
- int isNew;
- char *varName = TclGetString(varNamePtr);
+ ckfree(searchPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayExistsCmd --
+ *
+ * This object-based function is invoked to process the "array exists"
+ * Tcl command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArrayExistsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *arrayNameObj;
+ int notArray;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ arrayNameObj = objv[1];
+
+ /*
+ * Locate the array variable.
+ */
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- if (notArray) {
- goto error;
- }
- searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
- hPtr = Tcl_CreateHashEntry(&iPtr->varSearches,
- (char *) varPtr, &isNew);
- if (isNew) {
- searchPtr->id = 1;
- Tcl_AppendResult(interp, "s-1-", varName, NULL);
- varPtr->flags |= VAR_SEARCH_ACTIVE;
- searchPtr->nextPtr = NULL;
- } else {
- char string[TCL_INTEGER_SPACE];
+ }
- searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
- TclFormatInt(string, searchPtr->id);
- Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
- searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
- }
- searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
- &searchPtr->search);
- Tcl_SetHashValue(hPtr, searchPtr);
+ /*
+ * Check whether we've actually got an array variable.
+ */
+
+ notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr));
+ Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayGetCmd --
+ *
+ * This object-based function is invoked to process the "array get" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArrayGetCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr, *varPtr2;
+ Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
+ Tcl_Obj **nameObjPtr, *patternObj;
+ Tcl_HashSearch search;
+ const char *pattern;
+ int i, count, result;
+
+ switch (objc) {
+ case 2:
+ varNameObj = objv[1];
+ patternObj = NULL;
+ break;
+ case 3:
+ varNameObj = objv[1];
+ patternObj = objv[2];
break;
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?");
+ return TCL_ERROR;
}
- case ARRAY_EXISTS:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]);
- break;
- case ARRAY_GET: {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern = NULL;
- char *name;
- Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
- int i, count;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
- return TCL_ERROR;
+ }
+
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces. If not an array, it's an empty result.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ return TCL_OK;
+ }
+
+ pattern = (patternObj ? TclGetString(patternObj) : NULL);
+
+ /*
+ * Store the array names in a new object.
+ */
+
+ TclNewObj(nameLstObj);
+ Tcl_IncrRefCount(nameLstObj);
+ if ((patternObj != NULL) && TclMatchIsTrivial(pattern)) {
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj);
+ if (varPtr2 == NULL) {
+ goto searchDone;
}
- if (notArray) {
- return TCL_OK;
+ if (TclIsVarUndefined(varPtr2)) {
+ goto searchDone;
}
- if (objc == 4) {
- pattern = TclGetString(objv[3]);
+ result = Tcl_ListObjAppendElement(interp, nameLstObj,
+ VarHashGetKey(varPtr2));
+ if (result != TCL_OK) {
+ TclDecrRefCount(nameLstObj);
+ return result;
}
+ goto searchDone;
+ }
- /*
- * Store the array names in a new object.
- */
-
- TclNewObj(nameLstPtr);
- Tcl_IncrRefCount(nameLstPtr);
- if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
- varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]);
- if (varPtr2 == NULL) {
- goto searchDone;
- }
- if (TclIsVarUndefined(varPtr2)) {
- goto searchDone;
- }
- result = Tcl_ListObjAppendElement(interp, nameLstPtr,
- VarHashGetKey(varPtr2));
- if (result != TCL_OK) {
- TclDecrRefCount(nameLstPtr);
- return result;
- }
- goto searchDone;
+ for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2; varPtr2 = VarHashNextVar(&search)) {
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ nameObj = VarHashGetKey(varPtr2);
+ if (patternObj && !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
+ continue; /* Element name doesn't match pattern. */
}
- for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search);
- varPtr2; varPtr2 = VarHashNextVar(&search)) {
- if (TclIsVarUndefined(varPtr2)) {
- continue;
- }
- namePtr = VarHashGetKey(varPtr2);
- name = TclGetString(namePtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* Element name doesn't match pattern. */
- }
- result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr);
- if (result != TCL_OK) {
- TclDecrRefCount(nameLstPtr);
- return result;
- }
+ result = Tcl_ListObjAppendElement(interp, nameLstObj, nameObj);
+ if (result != TCL_OK) {
+ TclDecrRefCount(nameLstObj);
+ return result;
}
+ }
- searchDone:
- /*
- * Make sure the Var structure of the array is not removed by a trace
- * while we're working.
- */
+ /*
+ * Make sure the Var structure of the array is not removed by a trace
+ * while we're working.
+ */
- if (TclIsVarInHash(varPtr)) {
- VarHashRefCount(varPtr)++;
- }
+ searchDone:
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
- /*
- * Get the array values corresponding to each element name.
- */
+ /*
+ * Get the array values corresponding to each element name.
+ */
- TclNewObj(tmpResPtr);
- result = Tcl_ListObjGetElements(interp, nameLstPtr, &count,
- &namePtrPtr);
- if (result != TCL_OK) {
- goto errorInArrayGet;
- }
+ TclNewObj(tmpResObj);
+ result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr);
+ if (result != TCL_OK) {
+ goto errorInArrayGet;
+ }
- for (i=0 ; i<count ; i++) {
- namePtr = *namePtrPtr++;
- valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
- TCL_LEAVE_ERR_MSG);
- if (valuePtr == NULL) {
+ for (i=0 ; i<count ; i++) {
+ nameObj = *nameObjPtr++;
+ valueObj = Tcl_ObjGetVar2(interp, varNameObj, nameObj,
+ TCL_LEAVE_ERR_MSG);
+ if (valueObj == NULL) {
+ /*
+ * Some trace played a trick on us; we need to diagnose to adapt
+ * our behaviour: was the array element unset, or did the
+ * modification modify the complete array?
+ */
+
+ if (TclIsVarArray(varPtr)) {
/*
- * Some trace played a trick on us; we need to diagnose to
- * adapt our behaviour: was the array element unset, or did
- * the modification modify the complete array?
+ * The array itself looks OK, the variable was undefined:
+ * forget it.
*/
- if (TclIsVarArray(varPtr)) {
- /*
- * The array itself looks OK, the variable was undefined:
- * forget it.
- */
-
- continue;
- } else {
- result = TCL_ERROR;
- goto errorInArrayGet;
- }
- }
- result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr);
- if (result != TCL_OK) {
- goto errorInArrayGet;
+ continue;
}
+ result = TCL_ERROR;
+ goto errorInArrayGet;
}
- if (TclIsVarInHash(varPtr)) {
- VarHashRefCount(varPtr)--;
+ result = Tcl_DictObjPut(interp, tmpResObj, nameObj, valueObj);
+ if (result != TCL_OK) {
+ goto errorInArrayGet;
}
- Tcl_SetObjResult(interp, tmpResPtr);
- TclDecrRefCount(nameLstPtr);
- break;
+ }
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
+ Tcl_SetObjResult(interp, tmpResObj);
+ TclDecrRefCount(nameLstObj);
+ return TCL_OK;
- errorInArrayGet:
- if (TclIsVarInHash(varPtr)) {
- VarHashRefCount(varPtr)--;
- }
- TclDecrRefCount(nameLstPtr);
- TclDecrRefCount(tmpResPtr); /* Free unneeded temp result. */
- return result;
+ errorInArrayGet:
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
}
- case ARRAY_NAMES: {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern;
- char *name;
- Tcl_Obj *namePtr, *resultPtr, *patternPtr;
- int mode, matched = 0;
- static const char *options[] = {
- "-exact", "-glob", "-regexp", NULL
- };
- enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
-
- mode = OPT_GLOB;
-
- if ((objc < 3) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?");
- return TCL_ERROR;
- }
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 4) {
- patternPtr = objv[3];
- pattern = TclGetString(patternPtr);
- } else if (objc == 5) {
- patternPtr = objv[4];
- pattern = TclGetString(patternPtr);
- if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0,
- &mode) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
- patternPtr = NULL;
- pattern = NULL;
- }
- TclNewObj(resultPtr);
- if (((enum options) mode)==OPT_GLOB && pattern!=NULL &&
- TclMatchIsTrivial(pattern)) {
- varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternPtr);
- if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) {
- result = Tcl_ListObjAppendElement(interp, resultPtr,
- VarHashGetKey(varPtr2));
- if (result != TCL_OK) {
- TclDecrRefCount(resultPtr);
- return result;
- }
- }
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
- }
- for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
- varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
- if (TclIsVarUndefined(varPtr2)) {
- continue;
- }
- namePtr = VarHashGetKey(varPtr2);
- name = TclGetString(namePtr);
- if (objc > 3) {
- switch ((enum options) mode) {
- case OPT_EXACT:
- matched = (strcmp(name, pattern) == 0);
- break;
- case OPT_GLOB:
- matched = Tcl_StringMatch(name, pattern);
- break;
- case OPT_REGEXP:
- matched = Tcl_RegExpMatch(interp, name, pattern);
- if (matched < 0) {
- TclDecrRefCount(resultPtr);
- return TCL_ERROR;
- }
- break;
- }
- if (matched == 0) {
- continue;
- }
- }
+ TclDecrRefCount(nameLstObj);
+ TclDecrRefCount(tmpResObj); /* Free unneeded temp result. */
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayNamesCmd --
+ *
+ * This object-based function is invoked to process the "array names" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
- if (result != TCL_OK) {
- TclDecrRefCount(namePtr); /* Free unneeded name obj. */
- return result;
- }
- }
- Tcl_SetObjResult(interp, resultPtr);
- break;
+ /* ARGSUSED */
+static int
+ArrayNamesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *const options[] = {
+ "-exact", "-glob", "-regexp", NULL
+ };
+ enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr, *varPtr2;
+ Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj;
+ Tcl_HashSearch search;
+ const char *pattern = NULL;
+ int mode = OPT_GLOB;
+
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?");
+ return TCL_ERROR;
}
- case ARRAY_SET:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
- return TCL_ERROR;
- }
- return TclArraySet(interp, objv[2], objv[3]);
- case ARRAY_UNSET:
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ varNameObj = objv[1];
+ patternObj = (objc > 2 ? objv[objc-1] : NULL);
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 3) {
- /*
- * When no pattern is given, just unset the whole array.
- */
+ }
- return TclObjUnsetVar2(interp, varNamePtr, NULL, 0);
- } else {
- Tcl_HashSearch search;
- Var *varPtr2, *protectedVarPtr;
- const char *pattern = TclGetString(objv[3]);
+ /*
+ * Finish parsing the arguments.
+ */
+
+ if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option",
+ 0, &mode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces. If not an array, the result is empty.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Check for the trivial cases where we can use a direct lookup.
+ */
+
+ TclNewObj(resultObj);
+ if (patternObj) {
+ pattern = TclGetString(patternObj);
+ }
+ if ((mode==OPT_GLOB && patternObj && TclMatchIsTrivial(pattern))
+ || (mode==OPT_EXACT)) {
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj);
+ if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) {
/*
- * With a trivial pattern, we can just unset.
+ * This can't fail; lappending to an empty object always works.
*/
- if (TclMatchIsTrivial(pattern)) {
- varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]);
- if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) {
- return TclObjUnsetVar2(interp, varNamePtr, objv[3], 0);
+ Tcl_ListObjAppendElement(NULL, resultObj, VarHashGetKey(varPtr2));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+ }
+
+ /*
+ * Must scan the array to select the elements.
+ */
+
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ nameObj = VarHashGetKey(varPtr2);
+ if (patternObj) {
+ const char *name = TclGetString(nameObj);
+ int matched = 0;
+
+ switch ((enum options) mode) {
+ case OPT_EXACT:
+ Tcl_Panic("exact matching shouldn't get here");
+ case OPT_GLOB:
+ matched = Tcl_StringMatch(name, pattern);
+ break;
+ case OPT_REGEXP:
+ matched = Tcl_RegExpMatchObj(interp, nameObj, patternObj);
+ if (matched < 0) {
+ TclDecrRefCount(resultObj);
+ return TCL_ERROR;
}
- return TCL_OK;
+ break;
+ }
+ if (matched == 0) {
+ continue;
}
+ }
- /*
- * Non-trivial case (well, deeply tricky really). We peek inside
- * the hash iterator in order to allow us to guarantee that the
- * following element in the array will not be scrubbed until we
- * have dealt with it. This stops the overall iterator from ending
- * up pointing into deallocated memory. [Bug 2939073]
- */
+ Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArraySetCmd --
+ *
+ * This object-based function is invoked to process the "array set" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- protectedVarPtr = NULL;
- for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
- varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
- /*
- * Drop the extra ref immediately. We don't need to free it at
- * this point though; we'll be unsetting it if necessary soon.
- */
+ /* ARGSUSED */
+static int
+ArraySetCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
- if (varPtr2 == protectedVarPtr) {
- VarHashRefCount(varPtr2)--;
- }
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
+ return TCL_ERROR;
+ }
- /*
- * Guard the next item in the search chain by incrementing its
- * refcount. This guarantees that the hash table iterator
- * won't be dangling on the next time through the loop.
- */
+ /*
+ * Locate the array variable.
+ */
- if (search.nextEntryPtr != NULL) {
- protectedVarPtr = VarHashGetValue(search.nextEntryPtr);
- VarHashRefCount(protectedVarPtr)++;
- } else {
- protectedVarPtr = NULL;
- }
+ varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- if (!TclIsVarUndefined(varPtr2)) {
- Tcl_Obj *namePtr = VarHashGetKey(varPtr2);
-
- if (Tcl_StringMatch(TclGetString(namePtr), pattern)
- && TclObjUnsetVar2(interp, varNamePtr, namePtr,
- 0) != TCL_OK) {
- /*
- * If we incremented a refcount, we must decrement it
- * here as we will not be coming back properly due to
- * the error.
- */
-
- if (protectedVarPtr) {
- VarHashRefCount(protectedVarPtr)--;
- CleanupVar(protectedVarPtr, varPtr);
- }
- return TCL_ERROR;
- }
- } else {
- CleanupVar(varPtr2, varPtr);
- }
- }
- break;
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
+ return TCL_ERROR;
}
+ }
+
+ return TclArraySet(interp, objv[1], objv[2]);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArraySizeCmd --
+ *
+ * This object-based function is invoked to process the "array size" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArraySizeCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *varNameObj;
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ int size = 0;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ varNameObj = objv[1];
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- case ARRAY_SIZE: {
- Tcl_HashSearch search;
- Var *varPtr2;
- int size;
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- size = 0;
+ }
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces. We can only iterate over the array if it exists...
+ */
+
+ if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
/*
* Must iterate in order to get chance to check for present but
* "undefined" entries.
*/
- if (!notArray) {
- for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
- varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
- if (TclIsVarUndefined(varPtr2)) {
- continue;
- }
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
+ if (!TclIsVarUndefined(varPtr2)) {
size++;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
- break;
}
- case ARRAY_STATISTICS: {
- const char *stats;
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayStatsCmd --
+ *
+ * This object-based function is invoked to process the "array
+ * statistics" Tcl command. See the user documentation for details on
+ * what it does.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- if (notArray) {
- goto error;
- }
+ /* ARGSUSED */
+static int
+ArrayStatsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *varNameObj;
+ char *stats;
- stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
- if (stats != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
- ckfree((void *)stats);
- } else {
- Tcl_SetResult(interp,"error reading array statistics",TCL_STATIC);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ varNameObj = objv[1];
+
+ /*
+ * Locate the array variable.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- break;
}
+
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces.
+ */
+
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
+ "\" isn't an array", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
+ TclGetString(varNameObj), NULL);
+ return TCL_ERROR;
}
- return TCL_OK;
- error:
- Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr),
- "\" isn't an array", NULL);
- return TCL_ERROR;
+ stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
+ if (stats == NULL) {
+ Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
+ ckfree(stats);
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclArraySet --
+ * ArrayUnsetCmd --
*
- * Set the elements of an array. If there are no elements to set, create
- * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the
- * TclSetupEnv routine.
+ * This object-based function is invoked to process the "array unset" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
- * A variable will be created if one does not already exist.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
-int
-TclArraySet(
- Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Obj *arrayNameObj, /* The array name. */
- Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is
- * NULL, create an empty array. */
+ /* ARGSUSED */
+static int
+ArrayUnsetCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
{
- Var *varPtr, *arrayPtr;
- int result, i;
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr;
+ Tcl_Obj *varNameObj, *patternObj, *nameObj;
+ Tcl_HashSearch search;
+ const char *pattern;
+ const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */
- varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
- /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
- /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
- return TCL_ERROR;
- }
- if (arrayPtr) {
- CleanupVar(varPtr, arrayPtr);
- TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
+ switch (objc) {
+ case 2:
+ varNameObj = objv[1];
+ patternObj = NULL;
+ break;
+ case 3:
+ varNameObj = objv[1];
+ patternObj = objv[2];
+ break;
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?");
return TCL_ERROR;
}
- if (arrayElemObj == NULL) {
- goto ensureArray;
- }
-
/*
- * Install the contents of the dictionary or list into the array.
+ * Locate the array variable
*/
- if (arrayElemObj->typePtr == &tclDictType) {
- Tcl_Obj *keyPtr, *valuePtr;
- Tcl_DictSearch search;
- int done;
+ varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
+ /*
+ * Special array trace used to keep the env array in sync for array names,
+ * array get, etc.
+ */
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
return TCL_ERROR;
}
- if (done == 0) {
- /*
- * Empty, so we'll just force the array to be properly existing
- * instead.
- */
+ }
- goto ensureArray;
- }
+ /*
+ * Verify that it is indeed an array variable. This test comes after the
+ * traces - the variable may actually become an array as an effect of said
+ * traces.
+ */
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ return TCL_OK;
+ }
+
+ if (!patternObj) {
/*
- * Don't need to look at result of Tcl_DictObjFirst as we've just
- * successfully used a dictionary operation on the same object.
+ * When no pattern is given, just unset the whole array.
*/
- for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
- &keyPtr, &valuePtr, &done) ; !done ;
- Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
- /*
- * At this point, it would be nice if the key was directly usable
- * by the array. This isn't the case though.
- */
+ return TclObjUnsetVar2(interp, varNameObj, NULL, 0);
+ }
- Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
- keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+ /*
+ * With a trivial pattern, we can just unset.
+ */
- if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
- keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
+ pattern = TclGetString(patternObj);
+ if (TclMatchIsTrivial(pattern)) {
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj);
+ if (!varPtr2 || TclIsVarUndefined(varPtr2)) {
+ return TCL_OK;
}
- return TCL_OK;
- } else {
+ return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj,
+ unsetFlags, -1);
+ }
+
+ /*
+ * Non-trivial case (well, deeply tricky really). We peek inside the hash
+ * iterator in order to allow us to guarantee that the following element
+ * in the array will not be scrubbed until we have dealt with it. This
+ * stops the overall iterator from ending up pointing into deallocated
+ * memory. [Bug 2939073]
+ */
+
+ protectedVarPtr = NULL;
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
/*
- * Not a dictionary, so assume (and convert to, for backward-
- * -compatability reasons) a list.
+ * Drop the extra ref immediately. We don't need to free it at this
+ * point though; we'll be unsetting it if necessary soon.
*/
- int elemLen;
- Tcl_Obj **elemPtrs, *copyListObj;
-
- result = TclListObjGetElements(interp, arrayElemObj,
- &elemLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
- if (elemLen & 1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "list must have an even number of elements", -1));
- return TCL_ERROR;
- }
- if (elemLen == 0) {
- goto ensureArray;
+ if (varPtr2 == protectedVarPtr) {
+ VarHashRefCount(varPtr2)--;
}
/*
- * We needn't worry about traces invalidating arrayPtr: should that be
- * the case, TclPtrSetVar will return NULL so that we break out of the
- * loop and return an error.
+ * Guard the next (peeked) item in the search chain by incrementing
+ * its refcount. This guarantees that the hash table iterator won't be
+ * dangling on the next time through the loop.
*/
- copyListObj = TclListObjCopy(NULL, arrayElemObj);
- for (i=0 ; i<elemLen ; i+=2) {
- Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
- elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
-
- if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
- elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
- result = TCL_ERROR;
- break;
- }
+ if (search.nextEntryPtr != NULL) {
+ protectedVarPtr = VarHashGetValue(search.nextEntryPtr);
+ VarHashRefCount(protectedVarPtr)++;
+ } else {
+ protectedVarPtr = NULL;
}
- Tcl_DecrRefCount(copyListObj);
- return result;
- }
- /*
- * The list is empty make sure we have an array, or create one if
- * necessary.
- */
-
- ensureArray:
- if (varPtr != NULL) {
- if (TclIsVarArray(varPtr)) {
- /*
- * Already an array, done.
- */
+ /*
+ * If the variable is undefined, clean it out as it has been hit by
+ * something else (i.e., an unset trace).
+ */
- return TCL_OK;
+ if (TclIsVarUndefined(varPtr2)) {
+ CleanupVar(varPtr2, varPtr);
+ continue;
}
- if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+
+ nameObj = VarHashGetKey(varPtr2);
+ if (Tcl_StringMatch(TclGetString(nameObj), pattern)
+ && TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj,
+ nameObj, unsetFlags, -1) != TCL_OK) {
/*
- * Either an array element, or a scalar: lose!
+ * If we incremented a refcount, we must decrement it here as we
+ * will not be coming back properly due to the error.
*/
- TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
- needArray, -1);
+ if (protectedVarPtr) {
+ VarHashRefCount(protectedVarPtr)--;
+ CleanupVar(protectedVarPtr, varPtr);
+ }
return TCL_ERROR;
}
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = (TclVarHashTable *)
- ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
+ * TclInitArrayCmd --
+ *
+ * This creates the ensemble for the "array" command.
+ *
+ * Results:
+ * The handle for the created ensemble.
+ *
+ * Side effects:
+ * Creates a command in the global namespace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+Tcl_Command
+TclInitArrayCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+ static const EnsembleImplMap arrayImplMap[] = {
+ {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
+ {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
+ {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0},
+ {"get", ArrayGetCmd, NULL, NULL, NULL, 0},
+ {"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
+ {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
+ {"set", ArraySetCmd, NULL, NULL, NULL, 0},
+ {"size", ArraySizeCmd, NULL, NULL, NULL, 0},
+ {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
+ {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
+ {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+
+ return TclMakeEnsemble(interp, "array", arrayImplMap);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ObjMakeUpvar --
*
* This function does all of the work of the "global" and "upvar"
@@ -3553,6 +4322,7 @@ ObjMakeUpvar(
TclGetString(myNamePtr), "\": upvar won't create "
"namespace variable that refers to procedure variable",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
}
@@ -3652,6 +4422,8 @@ TclPtrObjMakeUpvar(
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create a scalar variable "
"that looks like an array element", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
+ NULL);
return TCL_ERROR;
}
}
@@ -3669,6 +4441,8 @@ TclPtrObjMakeUpvar(
myFlags|AVOID_RESOLVERS, /* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(myNamePtr), NULL);
return TCL_ERROR;
}
}
@@ -3676,14 +4450,18 @@ TclPtrObjMakeUpvar(
if (varPtr == otherPtr) {
Tcl_SetResult((Tcl_Interp *) iPtr,
"can't upvar from variable to itself", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" has traces: can't use for upvar", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
+ Var *linkPtr;
+
/*
* The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if it's
@@ -3691,22 +4469,23 @@ TclPtrObjMakeUpvar(
* disconnect it from the thing it currently refers to.
*/
- if (TclIsVarLink(varPtr)) {
- Var *linkPtr = varPtr->value.linkPtr;
- if (linkPtr == otherPtr) {
- return TCL_OK;
- }
- if (TclIsVarInHash(linkPtr)) {
- VarHashRefCount(linkPtr)--;
- if (TclIsVarUndefined(linkPtr)) {
- CleanupVar(linkPtr, NULL);
- }
- }
- } else {
+ if (!TclIsVarLink(varPtr)) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" already exists", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL);
return TCL_ERROR;
}
+
+ linkPtr = varPtr->value.linkPtr;
+ if (linkPtr == otherPtr) {
+ return TCL_OK;
+ }
+ if (TclIsVarInHash(linkPtr)) {
+ VarHashRefCount(linkPtr)--;
+ if (TclIsVarUndefined(linkPtr)) {
+ CleanupVar(linkPtr, NULL);
+ }
+ }
}
TclSetVarLink(varPtr);
varPtr->value.linkPtr = otherPtr;
@@ -3730,8 +4509,9 @@ TclPtrObjMakeUpvar(
*
* Side effects:
* The variable in frameName whose name is given by varName becomes
- * accessible under the name localName, so that references to localName
- * are redirected to the other variable like a symbolic link.
+ * accessible under the name localNameStr, so that references to
+ * localNameStr are redirected to the other variable like a symbolic
+ * link.
*
*----------------------------------------------------------------------
*/
@@ -3745,11 +4525,28 @@ Tcl_UpVar(
const char *varName, /* Name of a variable in interp to link to.
* May be either a scalar name or an element
* in an array. */
- const char *localName, /* Name of link variable. */
+ const char *localNameStr, /* Name of link variable. */
int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
- * indicates scope of localName. */
+ * indicates scope of localNameStr. */
{
- return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
+ int result;
+ CallFrame *framePtr;
+ Tcl_Obj *varNamePtr, *localNamePtr;
+
+ if (TclGetFrame(interp, frameName, &framePtr) == -1) {
+ return TCL_ERROR;
+ }
+
+ varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(varNamePtr);
+ localNamePtr = Tcl_NewStringObj(localNameStr, -1);
+ Tcl_IncrRefCount(localNamePtr);
+
+ result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0,
+ localNamePtr, flags, -1);
+ Tcl_DecrRefCount(varNamePtr);
+ Tcl_DecrRefCount(localNamePtr);
+ return result;
}
/*
@@ -3766,8 +4563,9 @@ Tcl_UpVar(
*
* Side effects:
* The variable in frameName whose name is given by part1 and part2
- * becomes accessible under the name localName, so that references to
- * localName are redirected to the other variable like a symbolic link.
+ * becomes accessible under the name localNameStr, so that references to
+ * localNameStr are redirected to the other variable like a symbolic
+ * link.
*
*----------------------------------------------------------------------
*/
@@ -3781,9 +4579,9 @@ Tcl_UpVar2(
const char *part1,
const char *part2, /* Two parts of source variable name to link
* to. */
- const char *localName, /* Name of link variable. */
+ const char *localNameStr, /* Name of link variable. */
int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
- * indicates scope of localName. */
+ * indicates scope of localNameStr. */
{
int result;
CallFrame *framePtr;
@@ -3795,7 +4593,7 @@ Tcl_UpVar2(
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
- localNamePtr = Tcl_NewStringObj(localName, -1);
+ localNamePtr = Tcl_NewStringObj(localNameStr, -1);
Tcl_IncrRefCount(localNamePtr);
result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
@@ -3837,33 +4635,33 @@ Tcl_GetVariableFullName(
Tcl_Obj *namePtr;
Namespace *nsPtr;
+ if (!varPtr || TclIsVarArrayElement(varPtr)) {
+ return;
+ }
+
/*
* Add the full name of the containing namespace (if any), followed by the
* "::" separator, then the variable name.
*/
- if (varPtr) {
- if (!TclIsVarArrayElement(varPtr)) {
- nsPtr = TclGetVarNsPtr(varPtr);
- if (nsPtr) {
- Tcl_AppendToObj(objPtr, nsPtr->fullName, -1);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_AppendToObj(objPtr, "::", 2);
- }
- }
- if (TclIsVarInHash(varPtr)) {
- if (!TclIsVarDeadHash(varPtr)) {
- namePtr = VarHashGetKey(varPtr);
- Tcl_AppendObjToObj(objPtr, namePtr);
- }
- } else if (iPtr->varFramePtr->procPtr) {
- int index = varPtr - iPtr->varFramePtr->compiledLocals;
+ nsPtr = TclGetVarNsPtr(varPtr);
+ if (nsPtr) {
+ Tcl_AppendToObj(objPtr, nsPtr->fullName, -1);
+ if (nsPtr != iPtr->globalNsPtr) {
+ Tcl_AppendToObj(objPtr, "::", 2);
+ }
+ }
+ if (TclIsVarInHash(varPtr)) {
+ if (!TclIsVarDeadHash(varPtr)) {
+ namePtr = VarHashGetKey(varPtr);
+ Tcl_AppendObjToObj(objPtr, namePtr);
+ }
+ } else if (iPtr->varFramePtr->procPtr) {
+ int index = varPtr - iPtr->varFramePtr->compiledLocals;
- if (index < iPtr->varFramePtr->numCompiledLocals) {
- namePtr = localName(iPtr->varFramePtr, index);
- Tcl_AppendObjToObj(objPtr, namePtr);
- }
- }
+ if (index < iPtr->varFramePtr->numCompiledLocals) {
+ namePtr = localName(iPtr->varFramePtr, index);
+ Tcl_AppendObjToObj(objPtr, namePtr);
}
}
}
@@ -3894,15 +4692,10 @@ Tcl_GlobalObjCmd(
{
Interp *iPtr = (Interp *) interp;
register Tcl_Obj *objPtr, *tailPtr;
- char *varName;
- register char *tail;
+ const char *varName;
+ register const char *tail;
int result, i;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
- return TCL_ERROR;
- }
-
/*
* If we are not executing inside a Tcl procedure, just return.
*/
@@ -4002,17 +4795,12 @@ Tcl_VariableObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- char *varName, *tail, *cp;
+ const char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
Tcl_Obj *varNamePtr, *tailPtr;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
- return TCL_ERROR;
- }
-
for (i=1 ; i<objc ; i+=2) {
/*
* Look up each variable in the current namespace context, creating it
@@ -4033,6 +4821,7 @@ Tcl_VariableObjCmd(
TclObjVarErrMsg(interp, varNamePtr, NULL, "define",
isArrayElement, -1);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
return TCL_ERROR;
}
@@ -4139,29 +4928,59 @@ Tcl_UpvarObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
- int result;
+ int result, hasLevel;
+ Tcl_Obj *levelObj;
if (objc < 3) {
- upvarSyntax:
Tcl_WrongNumArgs(interp, 1, objv,
"?level? otherVar localVar ?otherVar localVar ...?");
return TCL_ERROR;
}
+ if (objc & 1) {
+ /*
+ * Even number of arguments, so use the default level of "1" by
+ * passing NULL to TclObjGetFrame.
+ */
+
+ levelObj = NULL;
+ hasLevel = 0;
+ } else {
+ /*
+ * Odd number of arguments, so objv[1] must contain the level.
+ */
+
+ levelObj = objv[1];
+ hasLevel = 1;
+ }
+
/*
* Find the call frame containing each of the "other variables" to be
* linked to.
*/
- result = TclObjGetFrame(interp, objv[1], &framePtr);
+ result = TclObjGetFrame(interp, levelObj, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
- objc -= result+1;
- if ((objc & 1) != 0) {
- goto upvarSyntax;
+ if ((result == 0) && hasLevel) {
+ /*
+ * Synthesize an error message since TclObjGetFrame doesn't do this
+ * for this particular case.
+ */
+
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
+ return TCL_ERROR;
}
- objv += result+1;
+
+ /*
+ * We've now finished with parsing levels; skip to the variable names.
+ */
+
+ objc -= hasLevel+1;
+ objv += hasLevel+1;
/*
* Iterate over each (other variable, local variable) pair. Divide the
@@ -4204,8 +5023,8 @@ SetArraySearchObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
- char *string;
- char *end;
+ const char *string;
+ char *end; /* Can't be const due to strtoul defn. */
int id;
size_t offset;
@@ -4242,7 +5061,9 @@ SetArraySearchObj(
return TCL_OK;
syntax:
- Tcl_AppendResult(interp, "illegal search identifier \"",string,"\"",NULL);
+ Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return TCL_ERROR;
}
@@ -4278,11 +5099,11 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
- register char *string;
+ register const char *string;
register size_t offset;
int id;
ArraySearch *searchPtr;
- char *varName = TclGetString(varNamePtr);
+ const char *varName = TclGetString(varNamePtr);
/*
* Parse the id.
@@ -4296,17 +5117,9 @@ ParseSearchId(
* Extract the information out of the Tcl_Obj.
*/
-#if 1
id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1);
string = TclGetString(handleObj);
offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2);
-#else
- id = (int)(((char *) handleObj->internalRep.twoPtrValue.ptr1) -
- ((char *) NULL));
- string = TclGetString(handleObj);
- offset = (((char *) handleObj->internalRep.twoPtrValue.ptr2) -
- ((char *) NULL));
-#endif
/*
* This test cannot be placed inside the Tcl_Obj machinery, since it is
@@ -4316,6 +5129,8 @@ ParseSearchId(
if (strcmp(string+offset, varName) != 0) {
Tcl_AppendResult(interp, "search identifier \"", string,
"\" isn't for variable \"", varName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string,
+ NULL);
goto badLookup;
}
@@ -4330,10 +5145,10 @@ ParseSearchId(
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(&iPtr->varSearches, (char *) varPtr);
+ Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
- for (searchPtr = (ArraySearch *) Tcl_GetHashValue(hPtr);
- searchPtr != NULL; searchPtr = searchPtr->nextPtr) {
+ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ searchPtr = searchPtr->nextPtr) {
if (searchPtr->id == id) {
return searchPtr;
}
@@ -4372,11 +5187,11 @@ DeleteSearches(
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
- sPtr = Tcl_FindHashEntry(&iPtr->varSearches, (char *) arrayVarPtr);
- for (searchPtr = (ArraySearch *) Tcl_GetHashValue(sPtr);
- searchPtr != NULL; searchPtr = nextPtr) {
+ sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
+ for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
+ searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
- ckfree((char *) searchPtr);
+ ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(sPtr);
@@ -4425,14 +5240,14 @@ TclDeleteNamespaceVars(
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
- Tcl_IncrRefCount(objPtr);
+ Tcl_IncrRefCount(objPtr);
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
- UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
- NULL, flags);
- Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags,
+ -1);
+ Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */
/*
* Remove the variable from the table and force it undefined in case
@@ -4440,17 +5255,16 @@ TclDeleteNamespaceVars(
*/
if (TclIsVarTraced(varPtr)) {
+ Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
+ VarTrace *tracePtr = Tcl_GetHashValue(tPtr);
ActiveVarTrace *activePtr;
- Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces,
- (char *) varPtr);
- VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
- Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
Tcl_DeleteHashEntry(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
@@ -4511,9 +5325,9 @@ TclDeleteVars(
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
- varPtr = VarHashFirstVar(tablePtr, &search)) {
-
- UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags);
+ varPtr = VarHashFirstVar(tablePtr, &search)) {
+ UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags,
+ -1);
VarHashDeleteEntry(varPtr);
}
VarHashDeleteTable(tablePtr);
@@ -4556,7 +5370,7 @@ TclDeleteCompiledLocalVars(
namePtrPtr = &localName(framePtr, 0);
for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) {
UnsetVarStruct(varPtr, NULL, iPtr, *namePtrPtr, NULL,
- TCL_TRACE_UNSETS);
+ TCL_TRACE_UNSETS, i);
}
framePtr->numCompiledLocals = 0;
}
@@ -4589,9 +5403,10 @@ DeleteArray(
* or NULL if it is to be computed on
* demand. */
Var *varPtr, /* Pointer to variable structure. */
- int flags) /* Flags to pass to TclCallVarTraces:
+ int flags, /* Flags to pass to TclCallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */
+ int index)
{
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
@@ -4627,15 +5442,16 @@ DeleteArray(
elPtr->flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
- elNamePtr, flags,/* leaveErrMsg */ 0, -1);
+ elNamePtr, flags,/* leaveErrMsg */ 0, index);
}
- tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) elPtr);
- tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr);
+ tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
+ tracePtr = Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
- Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
+ prevPtr->nextPtr = NULL;
+ Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
Tcl_DeleteHashEntry(tPtr);
elPtr->flags &= ~VAR_ALL_TRACES;
@@ -4658,13 +5474,13 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree((char *) varPtr->value.tablePtr);
+ ckfree(varPtr->value.tablePtr);
}
/*
*----------------------------------------------------------------------
*
- * TclTclObjVarErrMsg --
+ * TclObjVarErrMsg --
*
* Generate a reasonable error message describing why a variable
* operation failed.
@@ -4721,6 +5537,9 @@ TclObjVarErrMsg(
* NULL. */
{
if (!part1Ptr) {
+ if (index == -1) {
+ Tcl_Panic("invalid part1Ptr and invalid index together");
+ }
part1Ptr = localName(((Interp *)interp)->varFramePtr, index);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't %s \"%s%s%s%s\": %s",
@@ -4764,7 +5583,7 @@ PanicOnSetVarName(
*
* INTERNALREP DEFINITION:
* ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache
- * or NULL if it is this same obj
+ * or NULL if it is this same obj
* ptrAndLongRep.value: index into locals table
*/
@@ -4772,7 +5591,8 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = (Tcl_Obj *) objPtr->internalRep.ptrAndLongRep.ptr;
+ Tcl_Obj *namePtr = objPtr->internalRep.ptrAndLongRep.ptr;
+
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
@@ -4869,12 +5689,12 @@ DupParsedVarName(
register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
register char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
char *elemCopy;
- unsigned int elemLen;
+ unsigned elemLen;
if (arrayPtr != NULL) {
Tcl_IncrRefCount(arrayPtr);
elemLen = strlen(elem);
- elemCopy = ckalloc(elemLen+1);
+ elemCopy = ckalloc(elemLen + 1);
memcpy(elemCopy, elem, elemLen);
*(elemCopy + elemLen) = '\0';
elem = elemCopy;
@@ -4891,7 +5711,8 @@ UpdateParsedVarName(
{
Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
- char *part1, *p;
+ const char *part1;
+ char *p;
int len1, len2, totalLen;
if (arrayPtr == NULL) {
@@ -4906,14 +5727,14 @@ UpdateParsedVarName(
len2 = strlen(part2);
totalLen = len1 + len2 + 2;
- p = ckalloc((unsigned int) totalLen + 1);
+ p = ckalloc(totalLen + 1);
objPtr->bytes = p;
objPtr->length = totalLen;
- memcpy(p, part1, (unsigned int) len1);
+ memcpy(p, part1, (unsigned) len1);
p += len1;
*p++ = '(';
- memcpy(p, part2, (unsigned int) len2);
+ memcpy(p, part2, (unsigned) len2);
p += len2;
*p++ = ')';
*p = '\0';
@@ -5002,7 +5823,7 @@ ObjFindNamespaceVar(
int result;
Tcl_Var var;
Tcl_Obj *simpleNamePtr;
- char *name = TclGetString(namePtr);
+ const char *name = TclGetString(namePtr);
/*
* If this namespace has a variable resolver, then give it first crack at
@@ -5023,7 +5844,7 @@ ObjFindNamespaceVar(
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
- result = (*cxtNsPtr->varResProc)(interp, name,
+ result = cxtNsPtr->varResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
@@ -5031,7 +5852,7 @@ ObjFindNamespaceVar(
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
- result = (*resPtr->varResProc)(interp, name,
+ result = resPtr->varResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
@@ -5040,7 +5861,7 @@ ObjFindNamespaceVar(
if (result == TCL_OK) {
return var;
} else if (result != TCL_CONTINUE) {
- return (Tcl_Var) NULL;
+ return NULL;
}
}
@@ -5113,16 +5934,15 @@ TclInfoVarsCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- char *varName, *pattern;
- const char *simplePattern;
+ const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
Var *varPtr;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- Tcl_Obj *listPtr, *elemObjPtr;
+ Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
- Tcl_Obj *simplePatternPtr = NULL, *varNamePtr;
+ Tcl_Obj *simplePatternPtr = NULL;
/*
* Get the pattern and find the "effective namespace" in which to list
@@ -5146,9 +5966,8 @@ TclInfoVarsCmd(
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
- &simplePattern);
+ TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -5174,8 +5993,7 @@ TclInfoVarsCmd(
listPtr = Tcl_NewListObj(0, NULL);
- if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)
- || specificNsInPattern) {
+ if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) {
/*
* There is no frame pointer, the frame pointer was pushed only to
* activate a namespace, or we are in a procedure call frame but a
@@ -5306,7 +6124,7 @@ TclInfoGlobalsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *varName, *pattern;
+ const char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Tcl_HashSearch search;
Var *varPtr;
@@ -5400,8 +6218,7 @@ TclInfoLocalsCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *patternPtr;
- Tcl_Obj *listPtr;
+ Tcl_Obj *patternPtr, *listPtr;
if (objc == 1) {
patternPtr = NULL;
@@ -5412,7 +6229,7 @@ TclInfoLocalsCmd(
return TCL_ERROR;
}
- if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) {
+ if (!HasLocalVars(iPtr->varFramePtr)) {
return TCL_OK;
}
@@ -5455,12 +6272,11 @@ AppendLocals(
Interp *iPtr = (Interp *) interp;
Var *varPtr;
int i, localVarCt;
- Tcl_Obj **varNamePtr;
- char *varName;
+ Tcl_Obj **varNamePtr, *objNamePtr;
+ const char *varName;
TclVarHashTable *localVarTablePtr;
Tcl_HashSearch search;
const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
- Tcl_Obj *objNamePtr;
localVarCt = iPtr->varFramePtr->numCompiledLocals;
varPtr = iPtr->varFramePtr->compiledLocals;
@@ -5543,16 +6359,16 @@ AllocVarEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr = keyPtr;
Tcl_HashEntry *hPtr;
Var *varPtr;
- varPtr = (Var *) ckalloc(sizeof(VarInHash));
+ varPtr = ckalloc(sizeof(VarInHash));
varPtr->flags = VAR_IN_HASHTABLE;
varPtr->value.objPtr = NULL;
VarHashRefCount(varPtr) = 1;
- hPtr = &(((VarInHash *)varPtr)->entry);
+ hPtr = &(((VarInHash *) varPtr)->entry);
Tcl_SetHashValue(hPtr, varPtr);
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
@@ -5569,7 +6385,7 @@ FreeVarEntry(
if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == 1)) {
- ckfree((char *) varPtr);
+ ckfree(varPtr);
} else {
VarHashInvalidateEntry(varPtr);
TclSetVarUndefined(varPtr);
@@ -5583,7 +6399,7 @@ CompareVarKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = hPtr->key.objPtr;
register const char *p1, *p2;
register int l1, l2;
@@ -5607,54 +6423,10 @@ CompareVarKeys(
l2 = objPtr2->length;
/*
- * Only compare if the string representations are of the same length.
+ * Only compare string representations of the same length.
*/
- if (l1 == l2) {
- for (;; p1++, p2++, l1--) {
- if (*p1 != *p2) {
- break;
- }
- if (l1 == 0) {
- return 1;
- }
- }
- }
-
- return 0;
-}
-
-static unsigned int
-HashVarKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key from which to compute hash value. */
-{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
- const char *string = TclGetString(objPtr);
- int length = objPtr->length;
- unsigned int result = 0;
- int i;
-
- /*
- * I tried a zillion different hash functions and asked many other people
- * for advice. Many people had their own favorite functions, all
- * different, but no-one had much idea why they were good ones. I chose
- * the one below (multiply by 9 and add new character) because of the
- * following reasons:
- *
- * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
- * multiplying by 9 is just about as good.
- * 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the hash value
- * for ever, plus they spread fairly rapidly up to the high-order bits
- * to fill out the hash value. This seems works well both for decimal
- * and non-decimal strings.
- */
-
- for (i=0 ; i<length ; i++) {
- result += (result << 3) + string[i];
- }
- return result;
+ return ((l1 == l2) && !memcmp(p1, p2, l1));
}
/*
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
new file mode 100644
index 0000000..3ddc3fb
--- /dev/null
+++ b/generic/tclZlib.c
@@ -0,0 +1,2945 @@
+/*
+ * tclZlib.c --
+ *
+ * This file provides the interface to the Zlib library.
+ *
+ * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net>
+ * Copyright (C) 2005 Unitas Software B.V.
+ * Copyright (c) 2008-2009 Donal K. Fellows
+ *
+ * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the
+ * public domain March 2003.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#ifdef HAVE_ZLIB
+#include <zlib.h>
+
+/*
+ * Magic flags used with wbits fields to indicate that we're handling the gzip
+ * format or automatic detection of format. Putting it here is slightly less
+ * gross!
+ */
+
+#define WBITS_RAW (-MAX_WBITS)
+#define WBITS_ZLIB (MAX_WBITS)
+#define WBITS_GZIP (MAX_WBITS | 16)
+#define WBITS_AUTODETECT (MAX_WBITS | 32)
+
+/*
+ * Structure used for handling gzip headers that are generated from a
+ * dictionary. It comprises the header structure itself plus some working
+ * space that it is very convenient to have attached.
+ */
+
+#define MAX_COMMENT_LEN 256
+
+typedef struct {
+ gz_header header;
+ char nativeFilenameBuf[MAXPATHLEN];
+ char nativeCommentBuf[MAX_COMMENT_LEN];
+} GzipHeader;
+
+/*
+ * Structure used for the Tcl_ZlibStream* commands and [zlib stream ...]
+ */
+
+typedef struct {
+ Tcl_Interp *interp;
+ z_stream stream; /* The interface to the zlib library. */
+ int streamEnd; /* If we've got to end-of-stream. */
+ Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
+ Tcl_Obj *currentInput; /* Pointer to what is currently being
+ * inflated. */
+ int outPos;
+ int mode; /* Either TCL_ZLIB_STREAM_DEFLATE or
+ * TCL_ZLIB_STREAM_INFLATE. */
+ int format; /* Flags from the TCL_ZLIB_FORMAT_* */
+ int level; /* Default 5, 0-9 */
+ int flush; /* Stores the flush param for deferred the
+ * decompression. */
+ int wbits; /* The encoded compression mode, so we can
+ * restart the stream if necessary. */
+ Tcl_Command cmd; /* Token for the associated Tcl command. */
+} ZlibStreamHandle;
+
+/*
+ * Structure used for stacked channel compression and decompression.
+ */
+
+typedef struct {
+ Tcl_Channel chan; /* Reference to the channel itself. */
+ Tcl_Channel parent; /* The underlying source and sink of bytes. */
+ int flags; /* General flag bits, see below... */
+ int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
+ * for compression on output, or
+ * TCL_ZLIB_STREAM_INFLATE for decompression
+ * on input. */
+ z_stream inStream; /* Structure used by zlib for decompression of
+ * input. */
+ z_stream outStream; /* Structure used by zlib for compression of
+ * output. */
+ char *inBuffer, *outBuffer; /* Working buffers. */
+ int inAllocated, outAllocated;
+ /* Sizes of working buffers. */
+ GzipHeader inHeader; /* Header read from input stream, when
+ * decompressing a gzip stream. */
+ GzipHeader outHeader; /* Header to write to an output stream, when
+ * compressing a gzip stream. */
+ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
+} ZlibChannelData;
+
+/*
+ * Value bits for the flags field. Definitions are:
+ * ASYNC - Whether this is an asynchronous channel.
+ * IN_HEADER - Whether the inHeader field has been registered with
+ * the input compressor.
+ * OUT_HEADER - Whether the outputHeader field has been registered
+ * with the output decompressor.
+ */
+
+#define ASYNC 0x1
+#define IN_HEADER 0x2
+#define OUT_HEADER 0x4
+
+/*
+ * Size of buffers allocated by default. Should be enough...
+ */
+
+#define DEFAULT_BUFFER_SIZE 4096
+
+/*
+ * Time to wait (in milliseconds) before flushing the channel when reading
+ * data through the transform.
+ */
+
+#define TRANSFORM_FLUSH_DELAY 5
+
+/*
+ * Prototypes for private procedures defined later in this file:
+ */
+
+static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
+static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
+static Tcl_DriverCloseProc ZlibTransformClose;
+static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
+static Tcl_DriverGetOptionProc ZlibTransformGetOption;
+static Tcl_DriverHandlerProc ZlibTransformHandler;
+static Tcl_DriverInputProc ZlibTransformInput;
+static Tcl_DriverOutputProc ZlibTransformOutput;
+static Tcl_DriverSetOptionProc ZlibTransformSetOption;
+static Tcl_DriverWatchProc ZlibTransformWatch;
+static Tcl_ObjCmdProc ZlibCmd;
+static Tcl_ObjCmdProc ZlibStreamCmd;
+
+static void ConvertError(Tcl_Interp *interp, int code);
+static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
+static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
+ GzipHeader *headerPtr, int *extraSizePtr);
+static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
+ int mode, int format, int level,
+ Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr);
+static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
+static void ZlibTransformTimerKill(ZlibChannelData *cd);
+static void ZlibTransformTimerRun(ClientData clientData);
+static void ZlibTransformTimerSetup(ZlibChannelData *cd);
+
+/*
+ * Type of zlib-based compressing and decompressing channels.
+ */
+
+static const Tcl_ChannelType zlibChannelType = {
+ "zlib",
+ TCL_CHANNEL_VERSION_3,
+ ZlibTransformClose,
+ ZlibTransformInput,
+ ZlibTransformOutput,
+ NULL, /* seekProc */
+ ZlibTransformSetOption,
+ ZlibTransformGetOption,
+ ZlibTransformWatch,
+ ZlibTransformGetHandle,
+ NULL, /* close2Proc */
+ ZlibTransformBlockMode,
+ NULL, /* flushProc */
+ ZlibTransformHandler,
+ NULL, /* wideSeekProc */
+ NULL,
+ NULL
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConvertError --
+ *
+ * Utility function for converting a zlib error into a Tcl error.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates the interpreter result and errorcode.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ConvertError(
+ Tcl_Interp *interp, /* Interpreter to store the error in. May be
+ * NULL, in which case nothing happens. */
+ int code) /* The zlib error code. */
+{
+ if (interp == NULL) {
+ return;
+ }
+
+ if (code == Z_ERRNO) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1));
+ } else {
+ const char *codeStr, *codeStr2 = NULL;
+ char codeStrBuf[TCL_INTEGER_SPACE];
+
+ switch (code) {
+ case Z_STREAM_ERROR: codeStr = "STREAM"; break;
+ case Z_DATA_ERROR: codeStr = "DATA"; break;
+ case Z_MEM_ERROR: codeStr = "MEM"; break;
+ case Z_BUF_ERROR: codeStr = "BUF"; break;
+ case Z_VERSION_ERROR: codeStr = "VERSION"; break;
+ default:
+ codeStr = "unknown";
+ codeStr2 = codeStrBuf;
+ sprintf(codeStrBuf, "%d", code);
+ break;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1));
+
+ /*
+ * Tricky point! We might pass NULL twice here (and will when the
+ * error type is known).
+ */
+
+ Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GenerateHeader --
+ *
+ * Function for creating a gzip header from the contents of a dictionary
+ * (as described in the documentation). GetValue is a helper function.
+ *
+ * Results:
+ * A Tcl result code.
+ *
+ * Side effects:
+ * Updates the fields of the given gz_header structure. Adds amount of
+ * extra space required for the header to the variable referenced by the
+ * extraSizePtr argument.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetValue(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictObj,
+ const char *nameStr,
+ Tcl_Obj **valuePtrPtr)
+{
+ Tcl_Obj *name = Tcl_NewStringObj(nameStr, -1);
+ int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr);
+
+ TclDecrRefCount(name);
+ return result;
+}
+
+static int
+GenerateHeader(
+ Tcl_Interp *interp, /* Where to put error messages. */
+ Tcl_Obj *dictObj, /* The dictionary whose contents are to be
+ * parsed. */
+ GzipHeader *headerPtr, /* Where to store the parsed-out values. */
+ int *extraSizePtr) /* Variable to add the length of header
+ * strings (filename, comment) to. */
+{
+ Tcl_Obj *value;
+ int len, result = TCL_ERROR;
+ const char *valueStr;
+ Tcl_Encoding latin1enc;
+ static const char *const types[] = {
+ "binary", "text"
+ };
+
+ /*
+ * RFC 1952 says that header strings are in ISO 8859-1 (LATIN-1).
+ */
+
+ latin1enc = Tcl_GetEncoding(NULL, "iso8859-1");
+ if (latin1enc == NULL) {
+ Tcl_Panic("no latin-1 encoding");
+ }
+
+ if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL) {
+ valueStr = Tcl_GetStringFromObj(value, &len);
+ Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
+ headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
+ NULL);
+ headerPtr->nativeCommentBuf[len] = '\0';
+ headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
+ *extraSizePtr += len;
+ }
+
+ if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL &&
+ Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) {
+ goto error;
+ }
+
+ if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL) {
+ valueStr = Tcl_GetStringFromObj(value, &len);
+ Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
+ headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
+ headerPtr->nativeFilenameBuf[len] = '\0';
+ headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf;
+ *extraSizePtr += len;
+ }
+
+ if (GetValue(interp, dictObj, "os", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL && Tcl_GetIntFromObj(interp, value,
+ &headerPtr->header.os) != TCL_OK) {
+ goto error;
+ }
+
+ /*
+ * Ignore the 'size' field, since that is controlled by the size of the
+ * input data.
+ */
+
+ if (GetValue(interp, dictObj, "time", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL && Tcl_GetLongFromObj(interp, value,
+ (long *) &headerPtr->header.time) != TCL_OK) {
+ goto error;
+ }
+
+ if (GetValue(interp, dictObj, "type", &value) != TCL_OK) {
+ goto error;
+ } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types,
+ "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) {
+ goto error;
+ }
+
+ result = TCL_OK;
+ error:
+ Tcl_FreeEncoding(latin1enc);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExtractHeader --
+ *
+ * Take the values out of a gzip header and store them in a dictionary.
+ * SetValue is a helper function.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates the dictionary, which must be writable (i.e. refCount < 2).
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline void
+SetValue(
+ Tcl_Obj *dictObj,
+ const char *key,
+ Tcl_Obj *value)
+{
+ Tcl_Obj *keyObj = Tcl_NewStringObj(key, -1);
+
+ Tcl_IncrRefCount(keyObj);
+ Tcl_DictObjPut(NULL, dictObj, keyObj, value);
+ TclDecrRefCount(keyObj);
+}
+
+static void
+ExtractHeader(
+ gz_header *headerPtr, /* The gzip header to extract from. */
+ Tcl_Obj *dictObj) /* The dictionary to store in. */
+{
+ Tcl_Encoding latin1enc = NULL;
+ Tcl_DString tmp;
+
+ if (headerPtr->comment != Z_NULL) {
+ if (latin1enc == NULL) {
+ /*
+ * RFC 1952 says that header strings are in ISO 8859-1 (LATIN-1).
+ */
+
+ latin1enc = Tcl_GetEncoding(NULL, "iso8859-1");
+ if (latin1enc == NULL) {
+ Tcl_Panic("no latin-1 encoding");
+ }
+ }
+
+ Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
+ &tmp);
+ SetValue(dictObj, "comment", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
+ Tcl_DStringLength(&tmp)));
+ Tcl_DStringFree(&tmp);
+ }
+ SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
+ if (headerPtr->name != Z_NULL) {
+ if (latin1enc == NULL) {
+ /*
+ * RFC 1952 says that header strings are in ISO 8859-1 (LATIN-1).
+ */
+
+ latin1enc = Tcl_GetEncoding(NULL, "iso8859-1");
+ if (latin1enc == NULL) {
+ Tcl_Panic("no latin-1 encoding");
+ }
+ }
+
+ Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
+ &tmp);
+ SetValue(dictObj, "filename", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
+ Tcl_DStringLength(&tmp)));
+ Tcl_DStringFree(&tmp);
+ }
+ if (headerPtr->os != 255) {
+ SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os));
+ }
+ if (headerPtr->time != 0 /* magic - no time */) {
+ SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time));
+ }
+ if (headerPtr->text != Z_UNKNOWN) {
+ SetValue(dictObj, "type",
+ Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1));
+ }
+
+ if (latin1enc != NULL) {
+ Tcl_FreeEncoding(latin1enc);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamInit --
+ *
+ * This command initializes a (de)compression context/handle for
+ * (de)compressing data in chunks.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The variable pointed to by zshandlePtr is initialised and memory
+ * allocated for internal state. Additionally, if interp is not null, a
+ * Tcl command is created and its name placed in the interp result obj.
+ *
+ * Note:
+ * At least one of interp and zshandlePtr should be non-NULL or the
+ * reference to the stream will be completely lost.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamInit(
+ Tcl_Interp *interp,
+ int mode, /* Either TCL_ZLIB_STREAM_INFLATE or
+ * TCL_ZLIB_STREAM_DEFLATE. */
+ int format, /* Flags from the TCL_ZLIB_FORMAT_* set. */
+ int level, /* 0-9 or TCL_ZLIB_COMPRESS_DEFAULT. */
+ Tcl_Obj *dictObj, /* Dictionary containing headers for gzip. */
+ Tcl_ZlibStream *zshandlePtr)
+{
+ int wbits = 0;
+ int e;
+ ZlibStreamHandle *zshPtr = NULL;
+ Tcl_DString cmdname;
+ Tcl_CmdInfo cmdinfo;
+
+ switch (mode) {
+ case TCL_ZLIB_STREAM_DEFLATE:
+ /*
+ * Compressed format is specified by the wbits parameter. See zlib.h
+ * for details.
+ */
+
+ switch (format) {
+ case TCL_ZLIB_FORMAT_RAW:
+ wbits = WBITS_RAW;
+ break;
+ case TCL_ZLIB_FORMAT_GZIP:
+ wbits = WBITS_GZIP;
+ break;
+ case TCL_ZLIB_FORMAT_ZLIB:
+ wbits = WBITS_ZLIB;
+ break;
+ default:
+ Tcl_Panic("incorrect zlib data format, must be "
+ "TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP or "
+ "TCL_ZLIB_FORMAT_RAW");
+ }
+ if (level < -1 || level > 9) {
+ Tcl_Panic("compression level should be between 0 (no compression)"
+ " and 9 (best compression) or -1 for default compression "
+ "level");
+ }
+ break;
+ case TCL_ZLIB_STREAM_INFLATE:
+ /*
+ * wbits are the same as DEFLATE, but FORMAT_AUTO is valid too.
+ */
+
+ switch (format) {
+ case TCL_ZLIB_FORMAT_RAW:
+ wbits = WBITS_RAW;
+ break;
+ case TCL_ZLIB_FORMAT_GZIP:
+ wbits = WBITS_GZIP;
+ break;
+ case TCL_ZLIB_FORMAT_ZLIB:
+ wbits = WBITS_ZLIB;
+ break;
+ case TCL_ZLIB_FORMAT_AUTO:
+ wbits = WBITS_AUTODETECT;
+ break;
+ default:
+ Tcl_Panic("incorrect zlib data format, must be "
+ "TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP, "
+ "TCL_ZLIB_FORMAT_RAW or TCL_ZLIB_FORMAT_AUTO");
+ }
+ break;
+ default:
+ Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
+ " TCL_ZLIB_STREAM_INFLATE");
+ }
+
+ zshPtr = ckalloc(sizeof(ZlibStreamHandle));
+ zshPtr->interp = interp;
+ zshPtr->mode = mode;
+ zshPtr->format = format;
+ zshPtr->level = level;
+ zshPtr->wbits = wbits;
+ zshPtr->currentInput = NULL;
+ zshPtr->streamEnd = 0;
+ memset(&zshPtr->stream, 0, sizeof(z_stream));
+
+ /*
+ * No output buffer available yet
+ */
+
+ if (mode == TCL_ZLIB_STREAM_DEFLATE) {
+ e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits,
+ MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
+ } else {
+ e = inflateInit2(&zshPtr->stream, wbits);
+ }
+
+ if (e != Z_OK) {
+ ConvertError(interp, e);
+ goto error;
+ }
+
+ /*
+ * I could do all this in C, but this is easier.
+ */
+
+ if (interp != NULL) {
+ if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) {
+ goto error;
+ }
+ Tcl_DStringInit(&cmdname);
+ Tcl_DStringAppend(&cmdname, "::tcl::zlib::streamcmd_", -1);
+ Tcl_DStringAppend(&cmdname, Tcl_GetString(Tcl_GetObjResult(interp)),
+ -1);
+ if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
+ &cmdinfo) == 1) {
+ Tcl_SetResult(interp,
+ "BUG: Stream command name already exists", TCL_STATIC);
+ Tcl_DStringFree(&cmdname);
+ goto error;
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ * Create the command.
+ */
+
+ zshPtr->cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdname),
+ ZlibStreamCmd, zshPtr, ZlibStreamCmdDelete);
+ Tcl_DStringFree(&cmdname);
+ if (zshPtr->cmd == NULL) {
+ goto error;
+ }
+ } else {
+ zshPtr->cmd = NULL;
+ }
+
+ /*
+ * Prepare the buffers for use.
+ */
+
+ zshPtr->inData = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(zshPtr->inData);
+ zshPtr->outData = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(zshPtr->outData);
+
+ zshPtr->outPos = 0;
+
+ /*
+ * Now set the variable pointed to by *zshandlePtr to the pointer to the
+ * zsh struct.
+ */
+
+ if (zshandlePtr) {
+ *zshandlePtr = (Tcl_ZlibStream) zshPtr;
+ }
+
+ return TCL_OK;
+ error:
+ ckfree(zshPtr);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibStreamCmdDelete --
+ *
+ * This is the delete command which Tcl invokes when a zlibstream command
+ * is deleted from the interpreter (on stream close, usually).
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ZlibStreamCmdDelete(
+ ClientData cd)
+{
+ ZlibStreamHandle *zshPtr = cd;
+
+ zshPtr->cmd = NULL;
+ ZlibStreamCleanup(zshPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamClose --
+ *
+ * This procedure must be called after (de)compression is done to ensure
+ * memory is freed and the command is deleted from the interpreter (if
+ * any).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamClose(
+ Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit. */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+
+ /*
+ * If the interp is set, deleting the command will trigger
+ * ZlibStreamCleanup in ZlibStreamCmdDelete. If no interp is set, call
+ * ZlibStreamCleanup directly.
+ */
+
+ if (zshPtr->interp && zshPtr->cmd) {
+ Tcl_DeleteCommandFromToken(zshPtr->interp, zshPtr->cmd);
+ } else {
+ ZlibStreamCleanup(zshPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibStreamCleanup --
+ *
+ * This procedure is called by either Tcl_ZlibStreamClose or
+ * ZlibStreamCmdDelete to cleanup the stream context.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Invalidates the zlib stream handle.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+ZlibStreamCleanup(
+ ZlibStreamHandle *zshPtr)
+{
+ if (!zshPtr->streamEnd) {
+ if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ deflateEnd(&zshPtr->stream);
+ } else {
+ inflateEnd(&zshPtr->stream);
+ }
+ }
+
+ if (zshPtr->inData) {
+ Tcl_DecrRefCount(zshPtr->inData);
+ }
+ if (zshPtr->outData) {
+ Tcl_DecrRefCount(zshPtr->outData);
+ }
+ if (zshPtr->currentInput) {
+ Tcl_DecrRefCount(zshPtr->currentInput);
+ }
+
+ ckfree(zshPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamReset --
+ *
+ * This procedure will reinitialize an existing stream handle.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Any data left in the (de)compression buffer is lost.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamReset(
+ Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ int e;
+
+ if (!zshPtr->streamEnd) {
+ if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ deflateEnd(&zshPtr->stream);
+ } else {
+ inflateEnd(&zshPtr->stream);
+ }
+ }
+ Tcl_SetByteArrayLength(zshPtr->inData, 0);
+ Tcl_SetByteArrayLength(zshPtr->outData, 0);
+ if (zshPtr->currentInput) {
+ Tcl_DecrRefCount(zshPtr->currentInput);
+ zshPtr->currentInput = NULL;
+ }
+
+ zshPtr->outPos = 0;
+ zshPtr->streamEnd = 0;
+ memset(&zshPtr->stream, 0, sizeof(z_stream));
+
+ /*
+ * No output buffer available yet.
+ */
+
+ if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED,
+ zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
+ } else {
+ e = inflateInit2(&zshPtr->stream, zshPtr->wbits);
+ }
+
+ if (e != Z_OK) {
+ ConvertError(zshPtr->interp, e);
+ /* TODO:cleanup */
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamGetCommandName --
+ *
+ * This procedure will return the command name associated with the
+ * stream.
+ *
+ * Results:
+ * A Tcl_Obj with the name of the Tcl command or NULL if no command is
+ * associated with the stream.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_ZlibStreamGetCommandName(
+ Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ Tcl_Obj *objPtr;
+
+ if (!zshPtr->interp) {
+ return NULL;
+ }
+
+ TclNewObj(objPtr);
+ Tcl_GetCommandFullName(zshPtr->interp, zshPtr->cmd, objPtr);
+ return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamEof --
+ *
+ * This procedure This function returns 0 or 1 depending on the state of
+ * the (de)compressor. For decompression, eof is reached when the entire
+ * compressed stream has been decompressed. For compression, eof is
+ * reached when the stream has been flushed with TCL_ZLIB_FINALIZE.
+ *
+ * Results:
+ * Integer.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamEof(
+ Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+
+ return zshPtr->streamEnd;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamChecksum --
+ *
+ * Return the checksum of the uncompressed data seen so far by the
+ * stream.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamChecksum(
+ Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+
+ return zshPtr->stream.adler;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamPut --
+ *
+ * Add data to the stream for compression or decompression from a
+ * bytearray Tcl_Obj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamPut(
+ Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
+ Tcl_Obj *data, /* Data to compress/decompress */
+ int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
+ * TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ char *dataTmp = NULL;
+ int e, size, outSize;
+ Tcl_Obj *obj;
+
+ if (zshPtr->streamEnd) {
+ if (zshPtr->interp) {
+ Tcl_SetResult(zshPtr->interp,
+ "already past compressed stream end", TCL_STATIC);
+ }
+ return TCL_ERROR;
+ }
+
+ if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size);
+ zshPtr->stream.avail_in = size;
+
+ /*
+ * Deflatebound doesn't seem to take various header sizes into
+ * account, so we add 100 extra bytes.
+ */
+
+ outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100;
+ zshPtr->stream.avail_out = outSize;
+ dataTmp = ckalloc(zshPtr->stream.avail_out);
+ zshPtr->stream.next_out = (Bytef *) dataTmp;
+
+ e = deflate(&zshPtr->stream, flush);
+ if ((e==Z_OK || e==Z_BUF_ERROR) && (zshPtr->stream.avail_out == 0)) {
+ if (outSize - zshPtr->stream.avail_out > 0) {
+ /*
+ * Output buffer too small.
+ */
+
+ obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
+ outSize - zshPtr->stream.avail_out);
+
+ /*
+ * Now append the compressed data to the outData list.
+ */
+
+ Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
+ }
+ if (outSize < 0xFFFF) {
+ outSize = 0xFFFF; /* There may be *lots* of data left to
+ * output... */
+ ckfree(dataTmp);
+ dataTmp = ckalloc(outSize);
+ }
+ zshPtr->stream.avail_out = outSize;
+ zshPtr->stream.next_out = (Bytef *) dataTmp;
+
+ e = deflate(&zshPtr->stream, flush);
+ }
+
+ /*
+ * And append the final data block.
+ */
+
+ if (outSize - zshPtr->stream.avail_out > 0) {
+ obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
+ outSize - zshPtr->stream.avail_out);
+
+ /*
+ * Now append the compressed data to the outData list.
+ */
+
+ Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
+ }
+
+ if (dataTmp) {
+ ckfree(dataTmp);
+ }
+ } else {
+ /*
+ * This is easy. Just append to the inData list.
+ */
+
+ Tcl_ListObjAppendElement(NULL, zshPtr->inData, data);
+
+ /*
+ * and we'll need the flush parameter for the Inflate call.
+ */
+
+ zshPtr->flush = flush;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibStreamGet --
+ *
+ * Retrieve data (now compressed or decompressed) from the stream into a
+ * bytearray Tcl_Obj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibStreamGet(
+ Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
+ Tcl_Obj *data, /* A place to append the data. */
+ int count) /* Number of bytes to grab as a maximum, you
+ * may get less! */
+{
+ ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ int e, i, listLen, itemLen, dataPos = 0;
+ Tcl_Obj *itemObj;
+ unsigned char *dataPtr, *itemPtr;
+ int existing;
+
+ /*
+ * Getting beyond the of stream, just return empty string.
+ */
+
+ if (zshPtr->streamEnd) {
+ return TCL_OK;
+ }
+
+ (void) Tcl_GetByteArrayFromObj(data, &existing);
+
+ if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
+ if (count == -1) {
+ /*
+ * The only safe thing to do is restict to 65k. We might cause a
+ * panic for out of memory if we just kept growing the buffer.
+ */
+
+ count = 65536;
+ }
+
+ /*
+ * Prepare the place to store the data.
+ */
+
+ dataPtr = Tcl_SetByteArrayLength(data, existing+count);
+ dataPtr += existing;
+
+ zshPtr->stream.next_out = dataPtr;
+ zshPtr->stream.avail_out = count;
+ if (zshPtr->stream.avail_in == 0) {
+ /*
+ * zlib will probably need more data to decompress.
+ */
+
+ if (zshPtr->currentInput) {
+ Tcl_DecrRefCount(zshPtr->currentInput);
+ zshPtr->currentInput = NULL;
+ }
+ Tcl_ListObjLength(NULL, zshPtr->inData, &listLen);
+ if (listLen > 0) {
+ /*
+ * There is more input available, get it from the list and
+ * give it to zlib. At this point, the data must not be shared
+ * since we require the bytearray representation to not vanish
+ * under our feet. [Bug 3081008]
+ */
+
+ Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj);
+ if (Tcl_IsShared(itemObj)) {
+ itemObj = Tcl_DuplicateObj(itemObj);
+ }
+ itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
+ Tcl_IncrRefCount(itemObj);
+ zshPtr->currentInput = itemObj;
+ zshPtr->stream.next_in = itemPtr;
+ zshPtr->stream.avail_in = itemLen;
+
+ /*
+ * And remove it from the list
+ */
+
+ Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL);
+ }
+ }
+
+ e = inflate(&zshPtr->stream, zshPtr->flush);
+ Tcl_ListObjLength(NULL, zshPtr->inData, &listLen);
+
+ while ((zshPtr->stream.avail_out > 0)
+ && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
+ /*
+ * State: We have not satisfied the request yet and there may be
+ * more to inflate.
+ */
+
+ if (zshPtr->stream.avail_in > 0) {
+ if (zshPtr->interp) {
+ Tcl_SetResult(zshPtr->interp,
+ "Unexpected zlib internal state during decompression",
+ TCL_STATIC);
+ }
+ Tcl_SetByteArrayLength(data, existing);
+ return TCL_ERROR;
+ }
+
+ if (zshPtr->currentInput) {
+ Tcl_DecrRefCount(zshPtr->currentInput);
+ zshPtr->currentInput = 0;
+ }
+
+ /*
+ * Get the next block of data to go to inflate. At this point, the
+ * data must not be shared since we require the bytearray
+ * representation to not vanish under our feet. [Bug 3081008]
+ */
+
+ Tcl_ListObjIndex(zshPtr->interp, zshPtr->inData, 0, &itemObj);
+ if (Tcl_IsShared(itemObj)) {
+ itemObj = Tcl_DuplicateObj(itemObj);
+ }
+ itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
+ Tcl_IncrRefCount(itemObj);
+ zshPtr->currentInput = itemObj;
+ zshPtr->stream.next_in = itemPtr;
+ zshPtr->stream.avail_in = itemLen;
+
+ /*
+ * Remove it from the list.
+ */
+
+ Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL);
+ listLen--;
+
+ /*
+ * And call inflate again.
+ */
+
+ e = inflate(&zshPtr->stream, zshPtr->flush);
+ }
+ if (zshPtr->stream.avail_out > 0) {
+ Tcl_SetByteArrayLength(data,
+ existing + count - zshPtr->stream.avail_out);
+ }
+ if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) {
+ Tcl_SetByteArrayLength(data, existing);
+ ConvertError(zshPtr->interp, e);
+ return TCL_ERROR;
+ }
+ if (e == Z_STREAM_END) {
+ zshPtr->streamEnd = 1;
+ if (zshPtr->currentInput) {
+ Tcl_DecrRefCount(zshPtr->currentInput);
+ zshPtr->currentInput = 0;
+ }
+ inflateEnd(&zshPtr->stream);
+ }
+ } else {
+ Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
+ if (count == -1) {
+ count = 0;
+ for (i=0; i<listLen; i++) {
+ Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
+ itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
+ if (i == 0) {
+ count += itemLen - zshPtr->outPos;
+ } else {
+ count += itemLen;
+ }
+ }
+ }
+
+ /*
+ * Prepare the place to store the data.
+ */
+
+ dataPtr = Tcl_SetByteArrayLength(data, existing + count);
+ dataPtr += existing;
+
+ while ((count > dataPos) &&
+ (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK)
+ && (listLen > 0)) {
+ /*
+ * Get the next chunk off our list of chunks and grab the data out
+ * of it.
+ */
+
+ Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
+ itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
+ if (itemLen-zshPtr->outPos >= count-dataPos) {
+ unsigned len = count - dataPos;
+
+ memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
+ zshPtr->outPos += len;
+ dataPos += len;
+ if (zshPtr->outPos == itemLen) {
+ zshPtr->outPos = 0;
+ }
+ } else {
+ unsigned len = itemLen - zshPtr->outPos;
+
+ memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
+ dataPos += len;
+ zshPtr->outPos = 0;
+ }
+ if (zshPtr->outPos == 0) {
+ Tcl_ListObjReplace(NULL, zshPtr->outData, 0, 1, 0, NULL);
+ listLen--;
+ }
+ }
+ Tcl_SetByteArrayLength(data, existing + dataPos);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibDeflate --
+ *
+ * Compress the contents of Tcl_Obj *data with compression level in
+ * output format, producing the compressed data in the interpreter
+ * result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibDeflate(
+ Tcl_Interp *interp,
+ int format,
+ Tcl_Obj *data,
+ int level,
+ Tcl_Obj *gzipHeaderDictObj)
+{
+ int wbits = 0, inLen = 0, e = 0, extraSize = 0;
+ Byte *inData = NULL;
+ z_stream stream;
+ GzipHeader header;
+ gz_header *headerPtr = NULL;
+ Tcl_Obj *obj;
+
+ if (!interp) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compressed format is specified by the wbits parameter. See zlib.h for
+ * details.
+ */
+
+ if (format == TCL_ZLIB_FORMAT_RAW) {
+ wbits = WBITS_RAW;
+ } else if (format == TCL_ZLIB_FORMAT_GZIP) {
+ wbits = WBITS_GZIP;
+
+ /*
+ * Need to allocate extra space for the gzip header and footer. The
+ * amount of space is (a bit less than) 32 bytes, plus a byte for each
+ * byte of string that we add. Note that over-allocation is not a
+ * problem. [Bug 2419061]
+ */
+
+ extraSize = 32;
+ if (gzipHeaderDictObj) {
+ headerPtr = &header.header;
+ memset(headerPtr, 0, sizeof(gz_header));
+ if (GenerateHeader(interp, gzipHeaderDictObj, &header,
+ &extraSize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ } else if (format == TCL_ZLIB_FORMAT_ZLIB) {
+ wbits = WBITS_ZLIB;
+ } else {
+ Tcl_Panic("incorrect zlib data format, must be TCL_ZLIB_FORMAT_ZLIB, "
+ "TCL_ZLIB_FORMAT_GZIP or TCL_ZLIB_FORMAT_ZLIB");
+ }
+
+ if (level < -1 || level > 9) {
+ Tcl_Panic("compression level should be between 0 (uncompressed) and "
+ "9 (best compression) or -1 for default compression level");
+ }
+
+ /*
+ * Allocate some space to store the output.
+ */
+
+ TclNewObj(obj);
+
+ /*
+ * Obtain the pointer to the byte array, we'll pass this pointer straight
+ * to the deflate command.
+ */
+
+ inData = Tcl_GetByteArrayFromObj(data, &inLen);
+ memset(&stream, 0, sizeof(z_stream));
+ stream.avail_in = (uInt) inLen;
+ stream.next_in = inData;
+
+ /*
+ * No output buffer available yet, will alloc after deflateInit2.
+ */
+
+ e = deflateInit2(&stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL,
+ Z_DEFAULT_STRATEGY);
+ if (e != Z_OK) {
+ goto error;
+ }
+
+ if (headerPtr != NULL) {
+ e = deflateSetHeader(&stream, headerPtr);
+ if (e != Z_OK) {
+ goto error;
+ }
+ }
+
+ /*
+ * Allocate the output buffer from the value of deflateBound(). This is
+ * probably too much space. Before returning to the caller, we will reduce
+ * it back to the actual compressed size.
+ */
+
+ stream.avail_out = deflateBound(&stream, inLen) + extraSize;
+ stream.next_out = Tcl_SetByteArrayLength(obj, stream.avail_out);
+
+ /*
+ * Perform the compression, Z_FINISH means do it in one go.
+ */
+
+ e = deflate(&stream, Z_FINISH);
+
+ if (e != Z_STREAM_END) {
+ e = deflateEnd(&stream);
+
+ /*
+ * deflateEnd() returns Z_OK when there are bytes left to compress, at
+ * this point we consider that an error, although we could continue by
+ * allocating more memory and calling deflate() again.
+ */
+
+ if (e == Z_OK) {
+ e = Z_BUF_ERROR;
+ }
+ } else {
+ e = deflateEnd(&stream);
+ }
+
+ if (e != Z_OK) {
+ goto error;
+ }
+
+ /*
+ * Reduce the bytearray length to the actual data length produced by
+ * deflate.
+ */
+
+ Tcl_SetByteArrayLength(obj, stream.total_out);
+ Tcl_SetObjResult(interp, obj);
+ return TCL_OK;
+
+ error:
+ ConvertError(interp, e);
+ TclDecrRefCount(obj);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibInflate --
+ *
+ * Decompress data in an object into the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ZlibInflate(
+ Tcl_Interp *interp,
+ int format,
+ Tcl_Obj *data,
+ int bufferSize,
+ Tcl_Obj *gzipHeaderDictObj)
+{
+ int wbits = 0, inLen = 0, e = 0, newBufferSize;
+ Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
+ z_stream stream;
+ gz_header header, *headerPtr = NULL;
+ Tcl_Obj *obj;
+ char *nameBuf = NULL, *commentBuf = NULL;
+
+ if (!interp) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compressed format is specified by the wbits parameter. See zlib.h for
+ * details.
+ */
+
+ switch (format) {
+ case TCL_ZLIB_FORMAT_RAW:
+ wbits = WBITS_RAW;
+ gzipHeaderDictObj = NULL;
+ break;
+ case TCL_ZLIB_FORMAT_ZLIB:
+ wbits = WBITS_ZLIB;
+ gzipHeaderDictObj = NULL;
+ break;
+ case TCL_ZLIB_FORMAT_GZIP:
+ wbits = WBITS_GZIP;
+ break;
+ case TCL_ZLIB_FORMAT_AUTO:
+ wbits = WBITS_AUTODETECT;
+ break;
+ default:
+ Tcl_Panic("incorrect zlib data format, must be TCL_ZLIB_FORMAT_ZLIB, "
+ "TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
+ "TCL_ZLIB_FORMAT_AUTO");
+ }
+
+ if (gzipHeaderDictObj) {
+ headerPtr = &header;
+ memset(headerPtr, 0, sizeof(gz_header));
+ nameBuf = ckalloc(MAXPATHLEN);
+ header.name = (Bytef *) nameBuf;
+ header.name_max = MAXPATHLEN - 1;
+ commentBuf = ckalloc(MAX_COMMENT_LEN);
+ header.comment = (Bytef *) commentBuf;
+ header.comm_max = MAX_COMMENT_LEN - 1;
+ }
+
+ inData = Tcl_GetByteArrayFromObj(data, &inLen);
+ if (bufferSize < 1) {
+ /*
+ * Start with a buffer (up to) 3 times the size of the input data.
+ */
+
+ if (inLen < 32*1024*1024) {
+ bufferSize = 3*inLen;
+ } else if (inLen < 256*1024*1024) {
+ bufferSize = 2*inLen;
+ } else {
+ bufferSize = inLen;
+ }
+ }
+
+ TclNewObj(obj);
+ outData = Tcl_SetByteArrayLength(obj, bufferSize);
+ memset(&stream, 0, sizeof(z_stream));
+ stream.avail_in = (uInt) inLen+1; /* +1 because zlib can "over-request"
+ * input (but ignore it!) */
+ stream.next_in = inData;
+ stream.avail_out = bufferSize;
+ stream.next_out = outData;
+
+ /*
+ * Initialize zlib for decompression.
+ */
+
+ e = inflateInit2(&stream, wbits);
+ if (e != Z_OK) {
+ goto error;
+ }
+ if (headerPtr) {
+ e = inflateGetHeader(&stream, headerPtr);
+ if (e != Z_OK) {
+ goto error;
+ }
+ }
+
+ /*
+ * Start the decompression cycle.
+ */
+
+ while (1) {
+ e = inflate(&stream, Z_FINISH);
+ if (e != Z_BUF_ERROR) {
+ break;
+ }
+
+ /*
+ * Not enough room in the output buffer. Increase it by five times the
+ * bytes still in the input buffer. (Because 3 times didn't do the
+ * trick before, 5 times is what we do next.) Further optimization
+ * should be done by the user, specify the decompressed size!
+ */
+
+ if ((stream.avail_in == 0) && (stream.avail_out > 0)) {
+ e = Z_STREAM_ERROR;
+ goto error;
+ }
+ newBufferSize = bufferSize + 5 * stream.avail_in;
+ if (newBufferSize == bufferSize) {
+ newBufferSize = bufferSize+1000;
+ }
+ newOutData = Tcl_SetByteArrayLength(obj, newBufferSize);
+
+ /*
+ * Set next out to the same offset in the new location.
+ */
+
+ stream.next_out = newOutData + stream.total_out;
+
+ /*
+ * And increase avail_out with the number of new bytes allocated.
+ */
+
+ stream.avail_out += newBufferSize - bufferSize;
+ outData = newOutData;
+ bufferSize = newBufferSize;
+ }
+
+ if (e != Z_STREAM_END) {
+ inflateEnd(&stream);
+ goto error;
+ }
+
+ e = inflateEnd(&stream);
+ if (e != Z_OK) {
+ goto error;
+ }
+
+ /*
+ * Reduce the BA length to the actual data length produced by deflate.
+ */
+
+ Tcl_SetByteArrayLength(obj, stream.total_out);
+ if (headerPtr != NULL) {
+ ExtractHeader(&header, gzipHeaderDictObj);
+ SetValue(gzipHeaderDictObj, "size",
+ Tcl_NewLongObj((long) stream.total_out));
+ ckfree(nameBuf);
+ ckfree(commentBuf);
+ }
+ Tcl_SetObjResult(interp, obj);
+ return TCL_OK;
+
+ error:
+ TclDecrRefCount(obj);
+ ConvertError(interp, e);
+ if (nameBuf) {
+ ckfree(nameBuf);
+ }
+ if (commentBuf) {
+ ckfree(commentBuf);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ZlibCRC32, Tcl_ZlibAdler32 --
+ *
+ * Access to the checksumming engines.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned int
+Tcl_ZlibCRC32(
+ unsigned int crc,
+ const unsigned char *buf,
+ int len)
+{
+ /* Nothing much to do, just wrap the crc32(). */
+ return crc32(crc, (Bytef *) buf, (unsigned) len);
+}
+
+unsigned int
+Tcl_ZlibAdler32(
+ unsigned int adler,
+ const unsigned char *buf,
+ int len)
+{
+ return adler32(adler, (Bytef *) buf, (unsigned) len);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibCmd --
+ *
+ * Implementation of the [zlib] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibCmd(
+ ClientData notUsed,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int command, dlen, mode, format, i, option, level = -1;
+ unsigned start, buffersize = 0;
+ Tcl_ZlibStream zh;
+ Byte *data;
+ Tcl_Obj *headerDictObj, *headerVarObj;
+ const char *extraInfoStr = NULL;
+ static const char *const commands[] = {
+ "adler32", "compress", "crc32", "decompress", "deflate", "gunzip",
+ "gzip", "inflate", "push", "stream",
+ NULL
+ };
+ enum zlibCommands {
+ CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE,
+ CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM
+ };
+ static const char *const stream_formats[] = {
+ "compress", "decompress", "deflate", "gunzip", "gzip", "inflate",
+ NULL
+ };
+ enum zlibFormats {
+ FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP,
+ FMT_INFLATE
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
+ &command) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum zlibCommands) command) {
+ case CMD_ADLER: /* adler32 str ?startvalue?
+ * -> checksum */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
+ return TCL_ERROR;
+ }
+ if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
+ (int *) &start) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc < 4) {
+ start = Tcl_ZlibAdler32(0, NULL, 0);
+ }
+ data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
+ Tcl_ZlibAdler32(start, data, dlen)));
+ return TCL_OK;
+ case CMD_CRC: /* crc32 str ?startvalue?
+ * -> checksum */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
+ return TCL_ERROR;
+ }
+ if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
+ (int *) &start) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc < 4) {
+ start = Tcl_ZlibCRC32(0, NULL, 0);
+ }
+ data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
+ Tcl_ZlibCRC32(start, data, dlen)));
+ return TCL_OK;
+ case CMD_DEFLATE: /* deflate data ?level?
+ * -> rawCompressedData */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level < 0 || level > 9) {
+ goto badLevel;
+ }
+ }
+ return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], level,
+ NULL);
+ case CMD_COMPRESS: /* compress data ?level?
+ * -> zlibCompressedData */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level < 0 || level > 9) {
+ goto badLevel;
+ }
+ }
+ return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level,
+ NULL);
+ case CMD_GZIP: /* gzip data ?level?
+ * -> gzippedCompressedData */
+ if (objc < 3 || objc > 7 || ((objc & 1) == 0)) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "data ?-level level? ?-header header?");
+ return TCL_ERROR;
+ }
+ headerDictObj = NULL;
+ for (i=3 ; i<objc ; i+=2) {
+ static const char *const gzipopts[] = {
+ "-header", "-level", NULL
+ };
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], gzipopts, "option", 0,
+ &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (option) {
+ case 0:
+ headerDictObj = objv[i+1];
+ break;
+ case 1:
+ if (Tcl_GetIntFromObj(interp, objv[i+1],
+ &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level < 0 || level > 9) {
+ extraInfoStr = "\n (in -level option)";
+ goto badLevel;
+ }
+ break;
+ }
+ }
+ return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level,
+ headerDictObj);
+ case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize?
+ * -> decompressedData */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3],
+ (int *) &buffersize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (buffersize < 16 || buffersize > 65536) {
+ goto badBuffer;
+ }
+ }
+ return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2],
+ buffersize, NULL);
+ case CMD_DECOMPRESS: /* decompress zlibcomprdata \
+ * ?bufferSize?
+ * -> decompressedData */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3],
+ (int *) &buffersize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (buffersize < 16 || buffersize > 65536) {
+ goto badBuffer;
+ }
+ }
+ return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2],
+ buffersize, NULL);
+ case CMD_GUNZIP: /* gunzip gzippeddata ?bufferSize?
+ * -> decompressedData */
+ if (objc < 3 || objc > 5 || ((objc & 1) == 0)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?");
+ return TCL_ERROR;
+ }
+ headerDictObj = headerVarObj = NULL;
+ for (i=3 ; i<objc ; i+=2) {
+ static const char *const gunzipopts[] = {
+ "-buffersize", "-headerVar", NULL
+ };
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
+ &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (option) {
+ case 0:
+ if (Tcl_GetIntFromObj(interp, objv[i+1],
+ (int *) &buffersize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (buffersize < 16 || buffersize > 65536) {
+ goto badBuffer;
+ }
+ break;
+ case 1:
+ headerVarObj = objv[i+1];
+ headerDictObj = Tcl_NewObj();
+ break;
+ }
+ }
+ if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2],
+ buffersize, headerDictObj) != TCL_OK) {
+ if (headerDictObj) {
+ TclDecrRefCount(headerDictObj);
+ }
+ return TCL_ERROR;
+ }
+ if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL,
+ headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ if (headerDictObj) {
+ TclDecrRefCount(headerDictObj);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ case CMD_STREAM: /* stream deflate/inflate/...gunzip \
+ * ?level?
+ * -> handleCmd */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
+ &format) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ mode = TCL_ZLIB_STREAM_INFLATE;
+ switch ((enum zlibFormats) format) {
+ case FMT_DEFLATE:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ case FMT_INFLATE:
+ format = TCL_ZLIB_FORMAT_RAW;
+ break;
+ case FMT_COMPRESS:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ case FMT_DECOMPRESS:
+ format = TCL_ZLIB_FORMAT_ZLIB;
+ break;
+ case FMT_GZIP:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ case FMT_GUNZIP:
+ format = TCL_ZLIB_FORMAT_GZIP;
+ break;
+ }
+ if (objc == 4) {
+ if (Tcl_GetIntFromObj(interp, objv[3],
+ (int *) &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level < 0 || level > 9) {
+ goto badLevel;
+ }
+ } else {
+ level = Z_DEFAULT_COMPRESSION;
+ }
+ if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL,
+ &zh) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh));
+ return TCL_OK;
+ case CMD_PUSH: { /* push mode channel options...
+ * -> channel */
+ Tcl_Channel chan;
+ int chanMode;
+ static const char *const pushOptions[] = {
+ "-header", "-level", "-limit",
+ NULL
+ };
+ enum pushOptions {poHeader, poLevel, poLimit};
+ Tcl_Obj *headerObj = NULL;
+ int limit = 1, dummy;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
+ &format) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum zlibFormats) format) {
+ case FMT_DEFLATE:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ format = TCL_ZLIB_FORMAT_RAW;
+ break;
+ case FMT_INFLATE:
+ mode = TCL_ZLIB_STREAM_INFLATE;
+ format = TCL_ZLIB_FORMAT_RAW;
+ break;
+ case FMT_COMPRESS:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ format = TCL_ZLIB_FORMAT_ZLIB;
+ break;
+ case FMT_DECOMPRESS:
+ mode = TCL_ZLIB_STREAM_INFLATE;
+ format = TCL_ZLIB_FORMAT_ZLIB;
+ break;
+ case FMT_GZIP:
+ mode = TCL_ZLIB_STREAM_DEFLATE;
+ format = TCL_ZLIB_FORMAT_GZIP;
+ break;
+ case FMT_GUNZIP:
+ mode = TCL_ZLIB_STREAM_INFLATE;
+ format = TCL_ZLIB_FORMAT_GZIP;
+ break;
+ default:
+ Tcl_AppendResult(interp, "IMPOSSIBLE", NULL);
+ return TCL_ERROR;
+ }
+
+ if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode,
+ 0) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Sanity checks.
+ */
+
+ if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
+ Tcl_AppendResult(interp,
+ "compression may only be applied to writable channels",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
+ Tcl_AppendResult(interp,
+ "decompression may only be applied to readable channels",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse options.
+ */
+
+ level = Z_DEFAULT_COMPRESSION;
+ for (i=4 ; i<objc ; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0,
+ &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum pushOptions) option) {
+ case poHeader:
+ if (++i > objc-1) {
+ Tcl_AppendResult(interp,
+ "value missing for -header option", NULL);
+ return TCL_ERROR;
+ }
+ headerObj = objv[i];
+ if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (in -header option)");
+ return TCL_ERROR;
+ }
+ break;
+ case poLevel:
+ if (++i > objc-1) {
+ Tcl_AppendResult(interp,
+ "value missing for -level option", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i],
+ (int *) &level) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (in -level option)");
+ return TCL_ERROR;
+ }
+ if (level < 0 || level > 9) {
+ extraInfoStr = "\n (in -level option)";
+ goto badLevel;
+ }
+ break;
+ case poLimit:
+ if (++i > objc-1) {
+ Tcl_AppendResult(interp,
+ "value missing for -limit option", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i],
+ (int *) &limit) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (in -limit option)");
+ return TCL_ERROR;
+ }
+ if (limit < 1) {
+ limit = 1;
+ }
+ break;
+ }
+ }
+
+ if (ZlibStackChannelTransform(interp, mode, format, level, chan,
+ headerObj) == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objv[3]);
+ return TCL_OK;
+ }
+ };
+
+ return TCL_ERROR;
+
+ badLevel:
+ Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+ if (extraInfoStr) {
+ Tcl_AddErrorInfo(interp, extraInfoStr);
+ }
+ return TCL_ERROR;
+ badBuffer:
+ Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibStreamCmd --
+ *
+ * Implementation of the commands returned by [zlib stream].
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibStreamCmd(
+ ClientData cd,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_ZlibStream zstream = cd;
+ int command, index, count, code, buffersize, flush = -1, i;
+ Tcl_Obj *obj;
+ static const char *const cmds[] = {
+ "add", "checksum", "close", "eof", "finalize", "flush",
+ "fullflush", "get", "put", "reset",
+ NULL
+ };
+ enum zlibStreamCommands {
+ zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush,
+ zs_fullflush, zs_get, zs_put, zs_reset
+ };
+ static const char *const add_options[] = {
+ "-buffer", "-finalize", "-flush", "-fullflush", NULL
+ };
+ enum addOptions {
+ ao_buffer, ao_finalize, ao_flush, ao_fullflush
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "option", 0,
+ &command) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum zlibStreamCommands) command) {
+ case zs_add: /* $strm add ?$flushopt? $data */
+ for (i=2; i<objc-1; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum addOptions) index) {
+ case ao_flush: /* -flush */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_SYNC_FLUSH;
+ }
+ break;
+ case ao_fullflush: /* -fullflush */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_FULL_FLUSH;
+ }
+ break;
+ case ao_finalize: /* -finalize */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_FINISH;
+ }
+ break;
+ case ao_buffer: /* -buffer */
+ if (i == objc-2) {
+ Tcl_AppendResult(interp, "\"-buffer\" option must be "
+ "followed by integer decompression buffersize",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1],
+ &buffersize) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (flush == -2) {
+ Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
+ "\"-finalize\" options are mutually exclusive", NULL);
+ return TCL_ERROR;
+ }
+ }
+ if (flush == -1) {
+ flush = 0;
+ }
+
+ if (Tcl_ZlibStreamPut(zstream, objv[objc-1],
+ flush) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ TclNewObj(obj);
+ code = Tcl_ZlibStreamGet(zstream, obj, -1);
+ if (code == TCL_OK) {
+ Tcl_SetObjResult(interp, obj);
+ } else {
+ TclDecrRefCount(obj);
+ }
+ return code;
+
+ case zs_put: /* $strm put ?$flushopt? $data */
+ for (i=2; i<objc-1; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum addOptions) index) {
+ case ao_flush: /* -flush */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_SYNC_FLUSH;
+ }
+ break;
+ case ao_fullflush: /* -fullflush */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_FULL_FLUSH;
+ }
+ break;
+ case ao_finalize: /* -finalize */
+ if (flush > -1) {
+ flush = -2;
+ } else {
+ flush = Z_FINISH;
+ }
+ break;
+ case ao_buffer:
+ Tcl_AppendResult(interp,
+ "\"-buffer\" option not supported here", NULL);
+ return TCL_ERROR;
+ }
+ if (flush == -2) {
+ Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
+ "\"-finalize\" options are mutually exclusive", NULL);
+ return TCL_ERROR;
+ }
+ }
+ if (flush == -1) {
+ flush = 0;
+ }
+ return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush);
+
+ case zs_get: /* $strm get ?count? */
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?count?");
+ return TCL_ERROR;
+ }
+
+ count = -1;
+ if (objc >= 3) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &count) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ TclNewObj(obj);
+ code = Tcl_ZlibStreamGet(zstream, obj, count);
+ if (code == TCL_OK) {
+ Tcl_SetObjResult(interp, obj);
+ } else {
+ TclDecrRefCount(obj);
+ }
+ return code;
+ case zs_flush: /* $strm flush */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ TclNewObj(obj);
+ Tcl_IncrRefCount(obj);
+ code = Tcl_ZlibStreamPut(zstream, obj, Z_SYNC_FLUSH);
+ TclDecrRefCount(obj);
+ return code;
+ case zs_fullflush: /* $strm fullflush */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ TclNewObj(obj);
+ Tcl_IncrRefCount(obj);
+ code = Tcl_ZlibStreamPut(zstream, obj, Z_FULL_FLUSH);
+ TclDecrRefCount(obj);
+ return code;
+ case zs_finalize: /* $strm finalize */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The flush commands slightly abuse the empty result obj as input
+ * data.
+ */
+
+ TclNewObj(obj);
+ Tcl_IncrRefCount(obj);
+ code = Tcl_ZlibStreamPut(zstream, obj, Z_FINISH);
+ TclDecrRefCount(obj);
+ return code;
+ case zs_close: /* $strm close */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return Tcl_ZlibStreamClose(zstream);
+ case zs_eof: /* $strm eof */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream)));
+ return TCL_OK;
+ case zs_checksum: /* $strm checksum */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
+ Tcl_ZlibStreamChecksum(zstream)));
+ return TCL_OK;
+ case zs_reset: /* $strm reset */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return Tcl_ZlibStreamReset(zstream);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * Set of functions to support channel stacking.
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibTransformClose(
+ ClientData instanceData,
+ Tcl_Interp *interp)
+{
+ ZlibChannelData *cd = instanceData;
+ int e, result = TCL_OK;
+
+ ZlibTransformTimerKill(cd);
+ if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ cd->outStream.avail_in = 0;
+ do {
+ cd->outStream.next_out = (Bytef *) cd->outBuffer;
+ cd->outStream.avail_out = (unsigned) cd->outAllocated;
+ e = deflate(&cd->outStream, Z_FINISH);
+ if (e != Z_OK && e != Z_STREAM_END) {
+ /* TODO: is this the right way to do errors on close? */
+ if (!TclInThreadExit()) {
+ ConvertError(interp, e);
+ }
+ result = TCL_ERROR;
+ break;
+ }
+ if (cd->outStream.avail_out != (unsigned) cd->outAllocated) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
+ cd->outAllocated - cd->outStream.avail_out) < 0) {
+ /* TODO: is this the right way to do errors on close?
+ * Note: when close is called from FinalizeIOSubsystem
+ * then interp may be NULL */
+ if (!TclInThreadExit()) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "error while finalizing file: ",
+ Tcl_PosixError(interp), NULL);
+ }
+ }
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ } while (e != Z_STREAM_END);
+ e = deflateEnd(&cd->inStream);
+ } else {
+ e = inflateEnd(&cd->outStream);
+ }
+
+ if (cd->inBuffer) {
+ ckfree(cd->inBuffer);
+ cd->inBuffer = NULL;
+ }
+ if (cd->outBuffer) {
+ ckfree(cd->outBuffer);
+ cd->outBuffer = NULL;
+ }
+ return result;
+}
+
+static int
+ZlibTransformInput(
+ ClientData instanceData,
+ char *buf,
+ int toRead,
+ int *errorCodePtr)
+{
+ ZlibChannelData *cd = instanceData;
+ Tcl_DriverInputProc *inProc =
+ Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
+ int e, readBytes, flush = Z_NO_FLUSH;
+
+ if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
+ errorCodePtr);
+ }
+
+ cd->inStream.next_out = (Bytef *) buf;
+ cd->inStream.avail_out = toRead;
+ if (cd->inStream.next_in == NULL) {
+ goto doReadFirst;
+ }
+ while (1) {
+ e = inflate(&cd->inStream, flush);
+ if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) {
+ return toRead - cd->inStream.avail_out;
+ }
+
+ /*
+ * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
+ *
+ * Just indicates that the zlib couldn't consume input/produce output,
+ * and is fixed by supplying more input.
+ */
+
+ if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
+ Tcl_Obj *errObj = Tcl_NewListObj(0, NULL);
+
+ Tcl_ListObjAppendElement(NULL, errObj,
+ Tcl_NewStringObj(cd->inStream.msg, -1));
+ Tcl_SetChannelError(cd->parent, errObj);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ /*
+ * Check if the inflate stopped early.
+ */
+
+ if (cd->inStream.avail_in > 0) {
+ continue;
+ }
+
+ /*
+ * Emptied the buffer of data from the underlying channel. Get some
+ * more.
+ */
+
+ doReadFirst:
+ /*
+ * Hack for Bug 2762041. Disable pre-reading of lots of input, read
+ * only one character. This way the Z_END_OF_STREAM can be read
+ * without triggering an EOF in the base channel. The higher input
+ * loops in DoReadChars() would react to that by stopping, despite the
+ * transform still having data which could be read.
+ *
+ * This is only a hack because other transforms may not be able to
+ * work around the general problem in this way.
+ */
+
+ readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1);
+ if (readBytes < 0) {
+ *errorCodePtr = Tcl_GetErrno();
+ return -1;
+ } else if (readBytes == 0) {
+ flush = Z_SYNC_FLUSH;
+ }
+
+ cd->inStream.next_in = (Bytef *) cd->inBuffer;
+ cd->inStream.avail_in = readBytes;
+ }
+}
+
+static int
+ZlibTransformOutput(
+ ClientData instanceData,
+ const char *buf,
+ int toWrite,
+ int *errorCodePtr)
+{
+ ZlibChannelData *cd = instanceData;
+ Tcl_DriverOutputProc *outProc =
+ Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent));
+ int e, produced;
+
+ if (cd->mode == TCL_ZLIB_STREAM_INFLATE) {
+ return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
+ errorCodePtr);
+ }
+
+ cd->outStream.next_in = (Bytef *) buf;
+ cd->outStream.avail_in = toWrite;
+ do {
+ cd->outStream.next_out = (Bytef *) cd->outBuffer;
+ cd->outStream.avail_out = cd->outAllocated;
+
+ e = deflate(&cd->outStream, Z_NO_FLUSH);
+ produced = cd->outAllocated - cd->outStream.avail_out;
+
+ if (e == Z_OK && cd->outStream.avail_out > 0) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
+ *errorCodePtr = Tcl_GetErrno();
+ return -1;
+ }
+ }
+ } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0);
+
+ if (e != Z_OK) {
+ Tcl_SetChannelError(cd->parent,
+ Tcl_NewStringObj(cd->outStream.msg, -1));
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ return toWrite - cd->outStream.avail_out;
+}
+
+static int
+ZlibTransformSetOption( /* not used */
+ ClientData instanceData,
+ Tcl_Interp *interp,
+ const char *optionName,
+ const char *value)
+{
+ ZlibChannelData *cd = instanceData;
+ Tcl_DriverSetOptionProc *setOptionProc =
+ Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent));
+ static const char *chanOptions = "flush";
+ int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE);
+
+ if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) {
+ int flushType;
+
+ if (value[0] == 'f' && strcmp(value, "full") == 0) {
+ flushType = Z_FULL_FLUSH;
+ goto doFlush;
+ }
+ if (value[0] == 's' && strcmp(value, "sync") == 0) {
+ flushType = Z_SYNC_FLUSH;
+ goto doFlush;
+ }
+ Tcl_AppendResult(interp, "unknown -flush type \"", value,
+ "\": must be full or sync", NULL);
+ return TCL_ERROR;
+
+ doFlush:
+ cd->outStream.avail_in = 0;
+ do {
+ int e;
+
+ cd->outStream.next_out = (Bytef *) cd->outBuffer;
+ cd->outStream.avail_out = cd->outAllocated;
+
+ e = deflate(&cd->outStream, flushType);
+ if (e != Z_OK) {
+ ConvertError(interp, e);
+ return TCL_ERROR;
+ }
+
+ if (cd->outStream.avail_out > 0) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
+ PTR2INT(cd->outStream.next_out)) < 0) {
+ Tcl_AppendResult(interp, "problem flushing channel: ",
+ Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ }
+ } while (cd->outStream.avail_out > 0);
+ return TCL_OK;
+ }
+
+ if (setOptionProc == NULL) {
+ return Tcl_BadChannelOption(interp, optionName, chanOptions);
+ }
+
+ return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp,
+ optionName, value);
+}
+
+static int
+ZlibTransformGetOption(
+ ClientData instanceData,
+ Tcl_Interp *interp,
+ const char *optionName,
+ Tcl_DString *dsPtr)
+{
+ ZlibChannelData *cd = instanceData;
+ Tcl_DriverGetOptionProc *getOptionProc =
+ Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent));
+ static const char *chanOptions = "checksum header";
+
+ /*
+ * The "crc" option reports the current CRC (calculated with the Adler32
+ * or CRC32 algorithm according to the format) given the data that has
+ * been processed so far.
+ */
+
+ if (optionName == NULL || strcmp(optionName, "-checksum") == 0) {
+ uLong crc;
+ char buf[12];
+
+ if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
+ crc = cd->outStream.adler;
+ } else {
+ crc = cd->inStream.adler;
+ }
+
+ sprintf(buf, "%lu", crc);
+ if (optionName == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "-checksum");
+ Tcl_DStringAppendElement(dsPtr, buf);
+ } else {
+ Tcl_DStringAppend(dsPtr, buf, -1);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * The "header" option, which is only valid on inflating gzip channels,
+ * reports the header that has been read from the start of the stream.
+ */
+
+ if ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
+ (strcmp(optionName, "-header") == 0))) {
+ Tcl_Obj *tmpObj = Tcl_NewObj();
+
+ ExtractHeader(&cd->inHeader.header, tmpObj);
+ if (optionName == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "-header");
+ Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj));
+ Tcl_DecrRefCount(tmpObj);
+ } else {
+ int len;
+ const char *str = Tcl_GetStringFromObj(tmpObj, &len);
+
+ Tcl_DStringAppend(dsPtr, str, len);
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * Now we do the standard processing of the stream we wrapped.
+ */
+
+ if (getOptionProc) {
+ return getOptionProc(Tcl_GetChannelInstanceData(cd->parent),
+ interp, optionName, dsPtr);
+ }
+ if (optionName == NULL) {
+ return TCL_OK;
+ }
+ return Tcl_BadChannelOption(interp, optionName, chanOptions);
+}
+
+static void
+ZlibTransformWatch(
+ ClientData instanceData,
+ int mask)
+{
+ ZlibChannelData *cd = instanceData;
+ Tcl_DriverWatchProc *watchProc;
+
+ /*
+ * This code is based on the code in tclIORTrans.c
+ */
+
+ watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
+ watchProc(Tcl_GetChannelInstanceData(cd->parent), mask);
+ if (!(mask & TCL_READABLE)
+ || (cd->inStream.avail_in == (uInt) cd->inAllocated)) {
+ ZlibTransformTimerKill(cd);
+ } else {
+ ZlibTransformTimerSetup(cd);
+ }
+}
+
+static int
+ZlibTransformGetHandle(
+ ClientData instanceData,
+ int direction,
+ ClientData *handlePtr)
+{
+ ZlibChannelData *cd = instanceData;
+
+ return Tcl_GetChannelHandle(cd->parent, direction, handlePtr);
+}
+
+static int
+ZlibTransformBlockMode(
+ ClientData instanceData,
+ int mode)
+{
+ ZlibChannelData *cd = instanceData;
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ cd->flags |= ASYNC;
+ } else {
+ cd->flags &= ~ASYNC;
+ }
+ return TCL_OK;
+}
+
+static int
+ZlibTransformHandler(
+ ClientData instanceData,
+ int interestMask)
+{
+ ZlibChannelData *cd = instanceData;
+
+ ZlibTransformTimerKill(cd);
+ return interestMask;
+}
+
+static void
+ZlibTransformTimerSetup(
+ ZlibChannelData *cd)
+{
+ if (cd->timer == NULL) {
+ cd->timer = Tcl_CreateTimerHandler(TRANSFORM_FLUSH_DELAY,
+ ZlibTransformTimerRun, cd);
+ }
+}
+
+static void
+ZlibTransformTimerKill(
+ ZlibChannelData *cd)
+{
+ if (cd->timer != NULL) {
+ Tcl_DeleteTimerHandler(cd->timer);
+ cd->timer = NULL;
+ }
+}
+
+static void
+ZlibTransformTimerRun(
+ ClientData clientData)
+{
+ ZlibChannelData *cd = clientData;
+
+ cd->timer = NULL;
+ Tcl_NotifyChannel(cd->chan, TCL_READABLE);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibStackChannelTransform --
+ *
+ * Stacks either compression or decompression onto a channel.
+ *
+ * Results:
+ * The stacked channel, or NULL if there was an error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZlibStackChannelTransform(
+ Tcl_Interp *interp, /* Where to write error messages. */
+ int mode, /* Whether this is a compressing transform
+ * (TCL_ZLIB_STREAM_DEFLATE) or a
+ * decompressing transform
+ * (TCL_ZLIB_STREAM_INFLATE). Note that
+ * compressing transforms require that the
+ * channel is writable, and decompressing
+ * transforms require that the channel is
+ * readable. */
+ int format, /* One of the TCL_ZLIB_FORMAT_* values that
+ * indicates what compressed format to allow.
+ * TCL_ZLIB_FORMAT_AUTO is only supported for
+ * decompressing transforms. */
+ int level, /* What compression level to use. Ignored for
+ * decompressing transforms. */
+ Tcl_Channel channel, /* The channel to attach to. */
+ Tcl_Obj *gzipHeaderDictPtr) /* A description of header to use, or NULL to
+ * use a default. Ignored if not compressing
+ * to produce gzip-format data. */
+{
+ ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData));
+ Tcl_Channel chan;
+ int wbits = 0;
+ int e;
+
+ if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) {
+ Tcl_Panic("unknown mode: %d", mode);
+ }
+
+ memset(cd, 0, sizeof(ZlibChannelData));
+ cd->mode = mode;
+
+ if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) {
+ if (mode == TCL_ZLIB_STREAM_DEFLATE) {
+ if (gzipHeaderDictPtr) {
+ int dummy = 0;
+
+ cd->flags |= OUT_HEADER;
+ if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader,
+ &dummy) != TCL_OK) {
+ goto error;
+ }
+ }
+ } else {
+ cd->flags |= IN_HEADER;
+ cd->inHeader.header.name = (Bytef *)
+ &cd->inHeader.nativeFilenameBuf;
+ cd->inHeader.header.name_max = MAXPATHLEN - 1;
+ cd->inHeader.header.comment = (Bytef *)
+ &cd->inHeader.nativeCommentBuf;
+ cd->inHeader.header.comm_max = MAX_COMMENT_LEN - 1;
+ }
+ }
+
+ if (format == TCL_ZLIB_FORMAT_RAW) {
+ wbits = WBITS_RAW;
+ } else if (format == TCL_ZLIB_FORMAT_ZLIB) {
+ wbits = WBITS_ZLIB;
+ } else if (format == TCL_ZLIB_FORMAT_GZIP) {
+ wbits = WBITS_GZIP;
+ } else if (format == TCL_ZLIB_FORMAT_AUTO) {
+ wbits = WBITS_AUTODETECT;
+ } else {
+ Tcl_Panic("bad format: %d", format);
+ }
+
+ /*
+ * Initialize input inflater or the output deflater.
+ */
+
+ if (mode == TCL_ZLIB_STREAM_INFLATE) {
+ e = inflateInit2(&cd->inStream, wbits);
+ if (e != Z_OK) {
+ goto error;
+ }
+ cd->inAllocated = DEFAULT_BUFFER_SIZE;
+ cd->inBuffer = ckalloc(cd->inAllocated);
+ if (cd->flags & IN_HEADER) {
+ e = inflateGetHeader(&cd->inStream, &cd->inHeader.header);
+ if (e != Z_OK) {
+ goto error;
+ }
+ }
+ } else {
+ e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits,
+ MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
+ if (e != Z_OK) {
+ goto error;
+ }
+ cd->outAllocated = DEFAULT_BUFFER_SIZE;
+ cd->outBuffer = ckalloc(cd->outAllocated);
+ if (cd->flags & OUT_HEADER) {
+ e = deflateSetHeader(&cd->outStream, &cd->outHeader.header);
+ if (e != Z_OK) {
+ goto error;
+ }
+ }
+ }
+
+ chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
+ Tcl_GetChannelMode(channel), channel);
+ if (chan == NULL) {
+ goto error;
+ }
+ cd->chan = chan;
+ cd->parent = Tcl_GetStackedChannel(chan);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
+ return chan;
+
+ error:
+ if (cd->inBuffer) {
+ ckfree(cd->inBuffer);
+ inflateEnd(&cd->inStream);
+ }
+ if (cd->outBuffer) {
+ ckfree(cd->outBuffer);
+ deflateEnd(&cd->outStream);
+ }
+ ckfree(cd);
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * Finally, the TclZlibInit function. Used to install the zlib API.
+ *----------------------------------------------------------------------
+ */
+
+int
+TclZlibInit(
+ Tcl_Interp *interp)
+{
+ /*
+ * This does two things. It creates a counter used in the creation of
+ * stream commands, and it creates the namespace that will contain those
+ * commands.
+ */
+
+ Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}");
+
+ /*
+ * Create the public scripted interface to this file's functionality.
+ */
+
+ Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * Stubs used when a suitable zlib installation was not found during
+ * configure.
+ *----------------------------------------------------------------------
+ */
+
+#else /* !HAVE_ZLIB */
+int
+Tcl_ZlibStreamInit(
+ Tcl_Interp *interp,
+ int mode,
+ int format,
+ int level,
+ Tcl_Obj *dictObj,
+ Tcl_ZlibStream *zshandle)
+{
+ Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ return TCL_ERROR;
+}
+
+int
+Tcl_ZlibStreamClose(
+ Tcl_ZlibStream zshandle)
+{
+ return TCL_OK;
+}
+
+int
+Tcl_ZlibStreamReset(
+ Tcl_ZlibStream zshandle)
+{
+ return TCL_OK;
+}
+
+Tcl_Obj *
+Tcl_ZlibStreamGetCommandName(
+ Tcl_ZlibStream zshandle)
+{
+ return NULL;
+}
+
+int
+Tcl_ZlibStreamEof(
+ Tcl_ZlibStream zshandle)
+{
+ return 1;
+}
+
+int
+Tcl_ZlibStreamChecksum(
+ Tcl_ZlibStream zshandle)
+{
+ return 0;
+}
+
+int
+Tcl_ZlibStreamPut(
+ Tcl_ZlibStream zshandle,
+ Tcl_Obj *data,
+ int flush)
+{
+ return TCL_OK;
+}
+
+int
+Tcl_ZlibStreamGet(
+ Tcl_ZlibStream zshandle,
+ Tcl_Obj *data,
+ int count)
+{
+ return TCL_OK;
+}
+
+int
+Tcl_ZlibDeflate(
+ Tcl_Interp *interp,
+ int format,
+ Tcl_Obj *data,
+ int level,
+ Tcl_Obj *gzipHeaderDictObj)
+{
+ Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ return TCL_ERROR;
+}
+
+int
+Tcl_ZlibInflate(
+ Tcl_Interp *interp,
+ int format,
+ Tcl_Obj *data,
+ int bufferSize,
+ Tcl_Obj *gzipHeaderDictObj)
+{
+ Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ return TCL_ERROR;
+}
+
+unsigned int
+Tcl_ZlibCRC32(
+ unsigned int crc,
+ const char *buf,
+ int len)
+{
+ return 0;
+}
+
+unsigned int
+Tcl_ZlibAdler32(
+ unsigned int adler,
+ const char *buf,
+ int len)
+{
+ return 0;
+}
+#endif /* HAVE_ZLIB */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-06-30 23:36:00 (GMT)