summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_color.c4
-rw-r--r--generic/regc_cvec.c2
-rw-r--r--generic/regc_lex.c12
-rw-r--r--generic/regc_locale.c92
-rw-r--r--generic/regc_nfa.c6
-rw-r--r--generic/regcomp.c69
-rw-r--r--generic/regcustom.h11
-rw-r--r--generic/rege_dfa.c4
-rw-r--r--generic/regerror.c3
-rw-r--r--generic/regex.h4
-rw-r--r--generic/regexec.c102
-rw-r--r--generic/regfree.c2
-rw-r--r--generic/regfronts.c2
-rw-r--r--generic/regguts.h35
-rw-r--r--generic/tcl.decls892
-rw-r--r--generic/tcl.h750
-rw-r--r--generic/tclAlloc.c88
-rwxr-xr-xgeneric/tclArithSeries.c1004
-rw-r--r--generic/tclArithSeries.h58
-rw-r--r--generic/tclAssembly.c138
-rw-r--r--generic/tclAsync.c216
-rw-r--r--generic/tclBasic.c2117
-rw-r--r--generic/tclBinary.c738
-rw-r--r--generic/tclCkalloc.c347
-rw-r--r--generic/tclClock.c174
-rw-r--r--generic/tclCmdAH.c825
-rw-r--r--generic/tclCmdIL.c1534
-rw-r--r--generic/tclCmdMZ.c1300
-rw-r--r--generic/tclCompCmds.c258
-rw-r--r--generic/tclCompCmdsGR.c406
-rw-r--r--generic/tclCompCmdsSZ.c510
-rw-r--r--generic/tclCompExpr.c190
-rw-r--r--generic/tclCompile.c760
-rw-r--r--generic/tclCompile.h289
-rw-r--r--generic/tclConfig.c35
-rw-r--r--generic/tclDate.c4
-rw-r--r--generic/tclDecls.h2096
-rw-r--r--generic/tclDictObj.c604
-rw-r--r--generic/tclDisassemble.c176
-rw-r--r--generic/tclEncoding.c1073
-rw-r--r--generic/tclEnsemble.c620
-rw-r--r--generic/tclEnv.c15
-rw-r--r--generic/tclEvent.c587
-rw-r--r--generic/tclExecute.c2544
-rw-r--r--generic/tclFCmd.c253
-rw-r--r--generic/tclFileName.c128
-rw-r--r--generic/tclFileSystem.h2
-rw-r--r--generic/tclGet.c34
-rw-r--r--generic/tclGetDate.y3
-rw-r--r--generic/tclHash.c190
-rw-r--r--generic/tclHistory.c17
-rw-r--r--generic/tclIO.c1014
-rw-r--r--generic/tclIO.h30
-rw-r--r--generic/tclIOCmd.c303
-rw-r--r--generic/tclIOGT.c107
-rw-r--r--generic/tclIORChan.c425
-rw-r--r--generic/tclIORTrans.c244
-rw-r--r--generic/tclIOSock.c104
-rw-r--r--generic/tclIOUtil.c2335
-rw-r--r--generic/tclIndexObj.c186
-rw-r--r--generic/tclInt.decls517
-rw-r--r--generic/tclInt.h1926
-rw-r--r--generic/tclIntDecls.h436
-rw-r--r--generic/tclIntPlatDecls.h35
-rw-r--r--generic/tclInterp.c284
-rw-r--r--generic/tclLink.c1304
-rw-r--r--generic/tclListObj.c3749
-rw-r--r--generic/tclLiteral.c112
-rw-r--r--generic/tclLoad.c925
-rw-r--r--generic/tclLoadNone.c50
-rw-r--r--generic/tclMain.c66
-rw-r--r--generic/tclNamesp.c406
-rw-r--r--generic/tclNotify.c340
-rw-r--r--generic/tclOO.c683
-rw-r--r--generic/tclOO.decls26
-rw-r--r--generic/tclOO.h38
-rw-r--r--generic/tclOOBasic.c184
-rw-r--r--generic/tclOOCall.c948
-rw-r--r--generic/tclOODecls.h67
-rw-r--r--generic/tclOODefineCmds.c860
-rw-r--r--generic/tclOOInfo.c316
-rw-r--r--generic/tclOOInt.h204
-rw-r--r--generic/tclOOMethod.c252
-rw-r--r--generic/tclOOScript.h263
-rw-r--r--generic/tclOOStubInit.c14
-rw-r--r--generic/tclOOStubLib.c9
-rw-r--r--generic/tclObj.c1561
-rw-r--r--generic/tclOptimize.c12
-rw-r--r--generic/tclPanic.c18
-rw-r--r--generic/tclParse.c258
-rw-r--r--generic/tclParse.h2
-rw-r--r--generic/tclPathObj.c757
-rw-r--r--generic/tclPipe.c88
-rw-r--r--generic/tclPkg.c559
-rw-r--r--generic/tclPkgConfig.c17
-rw-r--r--generic/tclPlatDecls.h40
-rw-r--r--generic/tclPort.h15
-rw-r--r--generic/tclPosixStr.c4
-rw-r--r--generic/tclPreserve.c23
-rw-r--r--generic/tclProc.c509
-rw-r--r--generic/tclProcess.c950
-rw-r--r--generic/tclRegexp.c90
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResolve.c8
-rw-r--r--generic/tclResult.c119
-rw-r--r--generic/tclScan.c77
-rw-r--r--generic/tclStrToD.c940
-rw-r--r--generic/tclStringObj.c2128
-rw-r--r--generic/tclStringRep.h41
-rw-r--r--generic/tclStubInit.c994
-rw-r--r--generic/tclStubLib.c56
-rw-r--r--generic/tclTest.c2063
-rw-r--r--generic/tclTestObj.c679
-rw-r--r--generic/tclTestProcBodyObj.c28
-rw-r--r--generic/tclThread.c57
-rw-r--r--generic/tclThreadAlloc.c166
-rw-r--r--generic/tclThreadJoin.c6
-rw-r--r--generic/tclThreadStorage.c22
-rw-r--r--generic/tclThreadTest.c88
-rw-r--r--generic/tclTimer.c74
-rw-r--r--generic/tclTomMath.decls166
-rw-r--r--generic/tclTomMath.h1156
-rw-r--r--generic/tclTomMathDecls.h552
-rw-r--r--generic/tclTomMathInterface.c136
-rw-r--r--generic/tclTomMathStubLib.c9
-rw-r--r--generic/tclTrace.c328
-rw-r--r--generic/tclUniData.c2
-rw-r--r--generic/tclUtf.c976
-rw-r--r--generic/tclUtil.c804
-rw-r--r--generic/tclVar.c1563
-rw-r--r--generic/tclZipfs.c6015
-rw-r--r--generic/tclZlib.c209
-rw-r--r--generic/tommath.h1
133 files changed, 42610 insertions, 21843 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c
index dc9f5b4..f1e25d2 100644
--- a/generic/regc_color.c
+++ b/generic/regc_color.c
@@ -2,7 +2,7 @@
* colorings of characters
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -761,7 +761,7 @@ dumpcolors(
chr c;
const char *has;
- fprintf(f, "max %ld\n", (long) cm->max);
+ fprintf(f, "max %" TCL_Z_MODIFIER "u\n", cm->max);
if (NBYTS > 1) {
fillcheck(cm, cm->tree, 0, f);
}
diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c
index d450d3e..3b4f1e4 100644
--- a/generic/regc_cvec.c
+++ b/generic/regc_cvec.c
@@ -2,7 +2,7 @@
* Utility functions for handling cvecs
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index d96d22f..eb068b4 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -2,7 +2,7 @@
* lexical analyzer
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -457,7 +457,7 @@ next(
if (ATEOS()) {
FAILW(REG_EESCAPE);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
switch (v->nexttype) { /* not all escapes okay here */
case PLAIN:
return 1;
@@ -716,7 +716,7 @@ next(
}
RETV(PLAIN, *v->now++);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
@@ -775,7 +775,7 @@ lexescape(
NOTE(REG_UNONPOSIX);
switch (c) {
case CHR('a'):
- RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007')));
+ RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\x07')));
break;
case CHR('A'):
RETV(SBEGIN, 0);
@@ -803,7 +803,7 @@ lexescape(
break;
case CHR('e'):
NOTE(REG_UUNPORT);
- RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033')));
+ RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\x1B')));
break;
case CHR('f'):
RETV(PLAIN, CHR('\f'));
@@ -1141,7 +1141,7 @@ skip(
/*
- newline - return the chr for a newline
* This helps confine use of CHR to this source file.
- ^ static chr newline(NOPARMS);
+ ^ static chr newline(void);
*/
static chr
newline(void)
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index 4f0ac88..1ac04ef 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -4,7 +4,7 @@
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,49 +16,49 @@ static const struct cname {
const char *name;
const char code;
} cnames[] = {
- {"NUL", '\0'},
- {"SOH", '\001'},
- {"STX", '\002'},
- {"ETX", '\003'},
- {"EOT", '\004'},
- {"ENQ", '\005'},
- {"ACK", '\006'},
- {"BEL", '\007'},
- {"alert", '\007'},
- {"BS", '\010'},
- {"backspace", '\b'},
- {"HT", '\011'},
- {"tab", '\t'},
- {"LF", '\012'},
- {"newline", '\n'},
- {"VT", '\013'},
- {"vertical-tab", '\v'},
- {"FF", '\014'},
- {"form-feed", '\f'},
- {"CR", '\015'},
- {"carriage-return", '\r'},
- {"SO", '\016'},
- {"SI", '\017'},
- {"DLE", '\020'},
- {"DC1", '\021'},
- {"DC2", '\022'},
- {"DC3", '\023'},
- {"DC4", '\024'},
- {"NAK", '\025'},
- {"SYN", '\026'},
- {"ETB", '\027'},
- {"CAN", '\030'},
- {"EM", '\031'},
- {"SUB", '\032'},
- {"ESC", '\033'},
- {"IS4", '\034'},
- {"FS", '\034'},
- {"IS3", '\035'},
- {"GS", '\035'},
- {"IS2", '\036'},
- {"RS", '\036'},
- {"IS1", '\037'},
- {"US", '\037'},
+ {"NUL", '\x00'},
+ {"SOH", '\x01'},
+ {"STX", '\x02'},
+ {"ETX", '\x03'},
+ {"EOT", '\x04'},
+ {"ENQ", '\x05'},
+ {"ACK", '\x06'},
+ {"BEL", '\x07'},
+ {"alert", '\x07'},
+ {"BS", '\x08'},
+ {"backspace", '\x08'},
+ {"HT", '\x09'},
+ {"tab", '\x09'},
+ {"LF", '\x0A'},
+ {"newline", '\x0A'},
+ {"VT", '\x0B'},
+ {"vertical-tab", '\x0B'},
+ {"FF", '\x0C'},
+ {"form-feed", '\x0C'},
+ {"CR", '\x0D'},
+ {"carriage-return", '\x0D'},
+ {"SO", '\x0E'},
+ {"SI", '\x0F'},
+ {"DLE", '\x10'},
+ {"DC1", '\x11'},
+ {"DC2", '\x12'},
+ {"DC3", '\x13'},
+ {"DC4", '\x14'},
+ {"NAK", '\x15'},
+ {"SYN", '\x16'},
+ {"ETB", '\x17'},
+ {"CAN", '\x18'},
+ {"EM", '\x19'},
+ {"SUB", '\x1A'},
+ {"ESC", '\x1B'},
+ {"IS4", '\x1C'},
+ {"FS", '\x1C'},
+ {"IS3", '\x1D'},
+ {"GS", '\x1D'},
+ {"IS2", '\x1E'},
+ {"RS", '\x1E'},
+ {"IS1", '\x1F'},
+ {"US", '\x1F'},
{"space", ' '},
{"exclamation-mark",'!'},
{"quotation-mark", '"'},
@@ -861,7 +861,7 @@ element(
*/
Tcl_DStringInit(&ds);
- np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
+ np = Tcl_UniCharToUtfDString(startp, len, &ds);
for (cn=cnames; cn->name!=NULL; cn++) {
if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
break; /* NOTE BREAK OUT */
@@ -1273,7 +1273,7 @@ cmp(
const chr *x, const chr *y, /* strings to compare */
size_t len) /* exact length of comparison */
{
- return memcmp(VS(x), VS(y), len*sizeof(chr));
+ return memcmp((void*)(x), (void*)(y), len*sizeof(chr));
}
/*
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 7f43958..f676a45 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -2,7 +2,7 @@
* NFA utilities.
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -843,7 +843,7 @@ moveins(
/*
- copyins - copy in arcs of a state to another state
- ^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyins(struct nfa *, struct state *, struct state *, int);
*/
static void
copyins(
@@ -1100,7 +1100,7 @@ moveouts(
/*
- copyouts - copy out arcs of a state to another state
- ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyouts(struct nfa *, struct state *, struct state *, int);
*/
static void
copyouts(
diff --git a/generic/regcomp.c b/generic/regcomp.c
index d828b44..c1ceb51 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -2,7 +2,7 @@
* re_*comp and friends - compile REs
* This file #includes several others (see the bottom).
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -56,7 +56,7 @@ static const chr *scanplain(struct vars *);
static void onechr(struct vars *, pchr, struct state *, struct state *);
static void dovec(struct vars *, struct cvec *, struct state *, struct state *);
static void wordchrs(struct vars *);
-static struct subre *subre(struct vars *, int, int, struct state *, struct state *);
+static struct subre *sub_re(struct vars *, int, int, struct state *, struct state *);
static void freesubre(struct vars *, struct subre *);
static void freesrnode(struct vars *, struct subre *);
static int numst(struct subre *, int);
@@ -81,7 +81,7 @@ static int lexescape(struct vars *);
static int lexdigits(struct vars *, int, int, int);
static int brenext(struct vars *, pchr);
static void skip(struct vars *);
-static chr newline(NOPARMS);
+static chr newline(void);
static chr chrnamed(struct vars *, const chr *, const chr *, pchr);
/* === regc_color.c === */
static void initcm(struct vars *, struct colormap *);
@@ -205,11 +205,11 @@ struct vars {
int cflags; /* copy of compile flags */
int lasttype; /* type of previous token */
int nexttype; /* type of next token */
- chr nextvalue; /* value (if any) of next token */
+ int nextvalue; /* value (if any) of next token */
int lexcon; /* lexical context type (see lex.c) */
int nsubexp; /* subexpression count */
struct subre **subs; /* subRE pointer vector */
- size_t nsubs; /* length of vector */
+ int nsubs; /* length of vector */
struct subre *sub10[10]; /* initial vector, enough for most */
struct nfa *nfa; /* the NFA */
struct colormap *cm; /* character color map */
@@ -287,8 +287,7 @@ compile(
{
AllocVars(v);
struct guts *g;
- int i;
- size_t j;
+ int i, j;
FILE *debug = (flags&REG_PROGRESS) ? stdout : NULL;
#define CNOERR() { if (ISERR()) return freev(v, v->err); }
@@ -341,13 +340,13 @@ compile(
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
- re->re_fns = (char *)&functions;
+ re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
- re->re_guts = (char *)(MALLOC(sizeof(struct guts)));
+ re->re_guts = (void*)(MALLOC(sizeof(struct guts)));
if (re->re_guts == NULL) {
return freev(v, REG_ESPACE);
}
@@ -433,7 +432,7 @@ compile(
* Can sacrifice main NFA now, so use it as work area.
*/
- (DISCARD) optimize(v->nfa, debug);
+ (void) optimize(v->nfa, debug);
CNOERR();
makesearch(v, v->nfa);
CNOERR();
@@ -476,10 +475,10 @@ moresubs(
int wanted) /* want enough room for this one */
{
struct subre **p;
- size_t n;
+ int n;
- assert(wanted > 0 && (size_t)wanted >= v->nsubs);
- n = (size_t)wanted * 3 / 2 + 1;
+ assert(wanted > 0 && wanted >= v->nsubs);
+ n = wanted * 3 / 2 + 1;
if (v->subs == v->sub10) {
p = (struct subre **) MALLOC(n * sizeof(struct subre *));
if (p != NULL) {
@@ -498,7 +497,7 @@ moresubs(
*p = NULL;
}
assert(v->nsubs == n);
- assert((size_t)wanted < v->nsubs);
+ assert(wanted < v->nsubs);
}
/*
@@ -664,7 +663,7 @@ parse(
assert(stopper == ')' || stopper == EOS);
- branches = subre(v, '|', LONGER, init, final);
+ branches = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branches;
firstbranch = 1;
@@ -674,7 +673,7 @@ parse(
* Need a place to hang the branch.
*/
- branch->right = subre(v, '|', LONGER, init, final);
+ branch->right = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branch->right;
}
@@ -745,7 +744,7 @@ parsebranch(
lp = left;
seencontent = 0;
- t = subre(v, '=', 0, left, right); /* op '=' is tentative */
+ t = sub_re(v, '=', 0, left, right); /* op '=' is tentative */
NOERRN();
while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) {
if (seencontent) { /* implicit concat operator */
@@ -809,7 +808,7 @@ parseqatom(
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
- subno = 0; /* just to shut lint up */
+ subno = 0;
/*
* An atom or constraint...
@@ -953,10 +952,10 @@ parseqatom(
if (cap) {
v->nsubexp++;
subno = v->nsubexp;
- if ((size_t)subno >= v->nsubs) {
+ if (subno >= v->nsubs) {
moresubs(v, subno);
}
- assert((size_t)subno < v->nsubs);
+ assert(subno < v->nsubs);
} else {
atomtype = PLAIN; /* something that's not '(' */
}
@@ -978,7 +977,7 @@ parseqatom(
NOERR();
if (cap) {
v->subs[subno] = atom;
- t = subre(v, '(', atom->flags|CAP, lp, rp);
+ t = sub_re(v, '(', atom->flags|CAP, lp, rp);
NOERR();
t->subno = subno;
t->left = atom;
@@ -996,7 +995,7 @@ parseqatom(
INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG);
NOERR();
assert(v->nextvalue > 0);
- atom = subre(v, 'b', BACKR, lp, rp);
+ atom = sub_re(v, 'b', BACKR, lp, rp);
NOERR();
subno = v->nextvalue;
atom->subno = subno;
@@ -1111,7 +1110,7 @@ parseqatom(
*/
if (atom == NULL) {
- atom = subre(v, '=', 0, lp, rp);
+ atom = sub_re(v, '=', 0, lp, rp);
NOERR();
}
@@ -1148,7 +1147,7 @@ parseqatom(
* Break remaining subRE into x{...} and what follows.
*/
- t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
+ t = sub_re(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
NOERR();
t->left = atom;
atomp = &t->left;
@@ -1162,7 +1161,7 @@ parseqatom(
*/
assert(top->op == '=' && top->left == NULL && top->right == NULL);
- top->left = subre(v, '=', top->flags, top->begin, lp);
+ top->left = sub_re(v, '=', top->flags, top->begin, lp);
NOERR();
top->op = '.';
top->right = t;
@@ -1231,9 +1230,9 @@ parseqatom(
assert(m >= 1 && m != DUPINF && n >= 1);
repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1);
f = COMBINE(qprefer, atom->flags);
- t = subre(v, '.', f, s, atom->end); /* prefix and atom */
+ t = sub_re(v, '.', f, s, atom->end); /* prefix and atom */
NOERR();
- t->left = subre(v, '=', PREF(f), s, atom->begin);
+ t->left = sub_re(v, '=', PREF(f), s, atom->begin);
NOERR();
t->right = atom;
*atomp = t;
@@ -1248,7 +1247,7 @@ parseqatom(
dupnfa(v->nfa, atom->begin, atom->end, s, s2);
repeat(v, s, s2, m, n);
f = COMBINE(qprefer, atom->flags);
- t = subre(v, '*', f, s, s2);
+ t = sub_re(v, '*', f, s, s2);
NOERR();
t->min = (short) m;
t->max = (short) n;
@@ -1266,7 +1265,7 @@ parseqatom(
t->right = parsebranch(v, stopper, type, s2, rp, 1);
} else {
EMPTYARC(s2, rp);
- t->right = subre(v, '=', 0, s2, rp);
+ t->right = sub_re(v, '=', 0, s2, rp);
}
NOERR();
assert(SEE('|') || SEE(stopper) || SEE(EOS));
@@ -1718,12 +1717,12 @@ wordchrs(
}
/*
- - subre - allocate a subre
- ^ static struct subre *subre(struct vars *, int, int, struct state *,
+ - sub_re - allocate a subre
+ ^ static struct subre *sub_re(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
-subre(
+sub_re(
struct vars *v,
int op,
int flags,
@@ -1900,10 +1899,10 @@ nfatree(
assert(t != NULL && t->begin != NULL);
if (t->left != NULL) {
- (DISCARD) nfatree(v, t->left, f);
+ (void) nfatree(v, t->left, f);
}
if (t->right != NULL) {
- (DISCARD) nfatree(v, t->right, f);
+ (void) nfatree(v, t->right, f);
}
return nfanode(v, t, f);
@@ -2147,7 +2146,7 @@ stdump(
fprintf(f, "}");
}
if (nfapresent) {
- fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no);
+ fprintf(f, " %d-%d", t->begin->no, t->end->no);
}
if (t->left != NULL) {
fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf)));
diff --git a/generic/regcustom.h b/generic/regcustom.h
index f6bf60c..5bda852 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -36,10 +36,9 @@
* Overrides for regguts.h definitions, if any.
*/
-#define FUNCPTR(name, args) (*name)args
-#define MALLOC(n) VS(attemptckalloc(n))
-#define FREE(p) ckfree(VS(p))
-#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n))
+#define MALLOC(n) (void*)(attemptckalloc(n))
+#define FREE(p) ckfree((void*)(p))
+#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n))
/*
* Do not insert extras between the "begin" and "end" lines - this chunk is
@@ -89,10 +88,10 @@ typedef int celt; /* Type to hold chr, or NOCELT */
#define NOCELT (-1) /* Celt value which is not valid chr */
#define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */
#define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
#define CHRBITS 32 /* Bits in a chr; must not use sizeof */
#define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */
-#define CHR_MAX 0xFFFFFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
+#define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
#else
#define CHRBITS 16 /* Bits in a chr; must not use sizeof */
#define CHR_MIN 0x0000 /* Smallest and largest chr; the value */
diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c
index e5f22c4..eddfea2 100644
--- a/generic/rege_dfa.c
+++ b/generic/rege_dfa.c
@@ -2,7 +2,7 @@
* DFA routines
* This file is #included by regexec.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -419,7 +419,7 @@ freeDFA(
static unsigned
hash(
unsigned *const uv,
- const int n)
+ int n)
{
int i;
unsigned h;
diff --git a/generic/regerror.c b/generic/regerror.c
index f783217..6606d41 100644
--- a/generic/regerror.c
+++ b/generic/regerror.c
@@ -1,7 +1,7 @@
/*
* regerror - error-code expansion
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -54,7 +54,6 @@ static const struct rerr {
/*
- regerror - the interface to error numbers
*/
-/* ARGSUSED */
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
diff --git a/generic/regex.h b/generic/regex.h
index adbd098..dba3ab4 100644
--- a/generic/regex.h
+++ b/generic/regex.h
@@ -151,8 +151,8 @@ typedef struct {
int re_csize; /* sizeof(character) */
char *re_endp; /* backward compatibility kludge */
/* the rest is opaque pointers to hidden innards */
- char *re_guts; /* `char *' is more portable than `void *' */
- char *re_fns;
+ void *re_guts;
+ void *re_fns;
} regex_t;
/* result reporting (may acquire more fields later) */
diff --git a/generic/regexec.c b/generic/regexec.c
index 0ab3c88..7ef048e 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -1,7 +1,7 @@
/*
* re_*exec and friends - match REs
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -44,7 +44,7 @@ struct sset { /* state set */
unsigned hash; /* hash of bitvector */
#define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
#define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
- memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
+ memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0))
int flags;
#define STARTER 01 /* the initial state set */
#define POSTSTATE 02 /* includes the goal state */
@@ -91,7 +91,6 @@ struct smalldfa {
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
};
-#define DOMALLOC ((struct smalldfa *)NULL) /* force malloc */
/*
* Internal variables, bundled for easy passing around.
@@ -117,7 +116,7 @@ struct vars {
#define ERR(e) VERR(v, e) /* record an error */
#define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */
#define OFF(p) ((p) - v->start)
-#define LOFF(p) ((long)OFF(p))
+#define LOFF(p) ((size_t)OFF(p))
/*
* forward declarations
@@ -146,7 +145,7 @@ static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *con
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 unsigned hash(unsigned *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);
@@ -172,8 +171,8 @@ exec(
{
AllocVars(v);
int st, backref;
- size_t n;
- size_t i;
+ int n;
+ int i;
#define LOCALMAT 20
regmatch_t mat[LOCALMAT];
#define LOCALDFAS 40
@@ -236,15 +235,16 @@ exec(
v->stop = (chr *)string + len;
v->err = 0;
assert(v->g->ntree >= 0);
- n = (size_t) v->g->ntree;
+ n = v->g->ntree;
if (n <= LOCALDFAS) {
v->subdfas = subdfas;
} else {
v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *));
}
if (v->subdfas == NULL) {
- if (v->pmatch != pmatch && v->pmatch != mat)
+ if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
+ }
FreeVars(v);
return REG_ESPACE;
}
@@ -269,7 +269,7 @@ exec(
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
zapallsubs(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
- memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
+ memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t));
}
/*
@@ -279,13 +279,15 @@ exec(
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
- n = (size_t) v->g->ntree;
+ n = v->g->ntree;
for (i = 0; i < n; i++) {
- if (v->subdfas[i] != NULL)
+ if (v->subdfas[i] != NULL) {
freeDFA(v->subdfas[i]);
+ }
}
- if (v->subdfas != subdfas)
+ if (v->subdfas != subdfas) {
FREE(v->subdfas);
+ }
FreeVars(v);
return st;
}
@@ -300,9 +302,10 @@ getsubdfa(struct vars * v,
struct subre * t)
{
if (v->subdfas[t->id] == NULL) {
- v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, DOMALLOC);
- if (ISERR())
+ v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
+ if (ISERR()) {
return NULL;
+ }
}
return v->subdfas[t->id];
}
@@ -332,7 +335,7 @@ simpleFind(
s = newDFA(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
- MDEBUG(("\nsearch at %ld\n", LOFF(v->start)));
+ MDEBUG(("\nsearch at %" TCL_Z_MODIFIER "u\n", LOFF(v->start)));
cold = NULL;
close = shortest(v, s, v->start, v->start, v->stop, &cold, NULL);
freeDFA(s);
@@ -360,12 +363,12 @@ simpleFind(
assert(cold != NULL);
open = cold;
cold = NULL;
- MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
+ MDEBUG(("between %" TCL_Z_MODIFIER "u and %" TCL_Z_MODIFIER "u\n", LOFF(open), LOFF(close)));
d = newDFA(v, cnfa, cm, &v->dfa1);
assert(!(ISERR() && d != NULL));
NOERR();
for (begin = open; begin <= close; begin++) {
- MDEBUG(("\nfind trying at %ld\n", LOFF(begin)));
+ MDEBUG(("\nfind trying at %" TCL_Z_MODIFIER "u\n", LOFF(begin)));
if (shorter) {
end = shortest(v, d, begin, begin, v->stop, NULL, &hitend);
} else {
@@ -476,7 +479,7 @@ complicatedFindLoop(
cold = NULL;
close = v->start;
do {
- MDEBUG(("\ncsearch at %ld\n", LOFF(close)));
+ MDEBUG(("\ncsearch at %" TCL_Z_MODIFIER "u\n", LOFF(close)));
close = shortest(v, s, close, close, v->stop, &cold, NULL);
if (close == NULL) {
break; /* NOTE BREAK */
@@ -484,9 +487,9 @@ complicatedFindLoop(
assert(cold != NULL);
open = cold;
cold = NULL;
- MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close)));
+ MDEBUG(("cbetween %" TCL_Z_MODIFIER "u and %" TCL_Z_MODIFIER "u\n", LOFF(open), LOFF(close)));
for (begin = open; begin <= close; begin++) {
- MDEBUG(("\ncomplicatedFind trying at %ld\n", LOFF(begin)));
+ MDEBUG(("\ncomplicatedFind trying at %" TCL_Z_MODIFIER "u\n", LOFF(begin)));
estart = begin;
estop = v->stop;
for (;;) {
@@ -502,7 +505,7 @@ complicatedFindLoop(
break; /* NOTE BREAK OUT */
}
- MDEBUG(("tentative end %ld\n", LOFF(end)));
+ MDEBUG(("tentative end %" TCL_Z_MODIFIER "u\n", LOFF(end)));
zapallsubs(v->pmatch, v->nmatch);
er = cdissect(v, v->g->tree, begin, end);
if (er == REG_OKAY) {
@@ -629,7 +632,7 @@ cdissect(
int er;
assert(t != NULL);
- MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op));
+ MDEBUG(("cdissect %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u %c\n", LOFF(begin), LOFF(end), t->op));
switch (t->op) {
case '=': /* terminal node */
@@ -716,7 +719,7 @@ ccondissect(
if (mid == NULL) {
return REG_NOMATCH;
}
- MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
@@ -767,7 +770,7 @@ ccondissect(
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
- MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid)));
+ MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
@@ -807,7 +810,7 @@ crevcondissect(
if (mid == NULL) {
return REG_NOMATCH;
}
- MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
@@ -858,7 +861,7 @@ crevcondissect(
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
- MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid)));
+ MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
@@ -890,7 +893,7 @@ cbrdissect(
MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));
/* get the backreferenced string */
- if (v->pmatch[n].rm_so == -1) {
+ if (v->pmatch[n].rm_so == TCL_INDEX_NONE) {
return REG_NOMATCH;
}
brstring = v->start + v->pmatch[n].rm_so;
@@ -924,17 +927,20 @@ cbrdissect(
assert(end > begin);
tlen = end - begin;
- if (tlen % brlen != 0)
+ if (tlen % brlen != 0) {
return REG_NOMATCH;
+ }
numreps = tlen / brlen;
- if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF))
+ if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF)) {
return REG_NOMATCH;
+ }
/* okay, compare the actual string contents */
p = begin;
while (numreps-- > 0) {
- if ((*v->g->compare) (brstring, p, brlen) != 0)
+ if ((*v->g->compare) (brstring, p, brlen) != 0) {
return REG_NOMATCH;
+ }
p += brlen;
}
@@ -1011,8 +1017,9 @@ citerdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1026,8 +1033,9 @@ citerdissect(struct vars * v,
* sub-match endpoints in endpts[1..max_matches].
*/
max_matches = end - begin;
- if (max_matches > (size_t)t->max && t->max != DUPINF)
+ if (max_matches > (size_t)t->max && t->max != DUPINF) {
max_matches = t->max;
+ }
if (max_matches < (size_t)min_matches)
max_matches = min_matches;
endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *));
@@ -1066,12 +1074,13 @@ citerdissect(struct vars * v,
k--;
goto backtrack;
}
- MDEBUG(("%d: working endpoint %d: %ld\n",
+ MDEBUG(("%d: working endpoint %d: %" TCL_Z_MODIFIER "u\n",
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
- if (nverified >= k)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1097,8 +1106,9 @@ citerdissect(struct vars * v,
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
- if (k < min_matches)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1109,8 +1119,9 @@ citerdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
@@ -1184,8 +1195,9 @@ creviterdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1239,8 +1251,9 @@ creviterdissect(struct vars * v,
limit++;
/* if this is the last allowed sub-match, it must reach to the end */
- if ((size_t)k >= max_matches)
+ if ((size_t)k >= max_matches) {
limit = end;
+ }
/* try to find an endpoint for the k'th sub-match */
endpts[k] = shortest(v, d, endpts[k - 1], limit, end,
@@ -1250,12 +1263,13 @@ creviterdissect(struct vars * v,
k--;
goto backtrack;
}
- MDEBUG(("%d: working endpoint %d: %ld\n",
+ MDEBUG(("%d: working endpoint %d: %" TCL_Z_MODIFIER "u\n",
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
- if (nverified >= k)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1276,8 +1290,9 @@ creviterdissect(struct vars * v,
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
- if (k < min_matches)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1288,8 +1303,9 @@ creviterdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
diff --git a/generic/regfree.c b/generic/regfree.c
index b0aaa70..71263ab 100644
--- a/generic/regfree.c
+++ b/generic/regfree.c
@@ -1,7 +1,7 @@
/*
* regfree - free an RE
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regfronts.c b/generic/regfronts.c
index 088a640..3042558 100644
--- a/generic/regfronts.c
+++ b/generic/regfronts.c
@@ -4,7 +4,7 @@
* Mostly for implementation of backward-compatibility kludges. Note that
* these routines exist ONLY in char versions.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regguts.h b/generic/regguts.h
index 71d04f3..de5d18e 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -49,41 +49,15 @@
#include <assert.h>
#endif
-/* voids */
-#ifndef VOID
-#define VOID void /* for function return values */
-#endif
-#ifndef DISCARD
-#define DISCARD void /* for throwing values away */
-#endif
-#ifndef PVOID
-#define PVOID void * /* generic pointer */
-#endif
-#ifndef VS
-#define VS(x) ((void*)(x)) /* cast something to generic ptr */
-#endif
-#ifndef NOPARMS
-#define NOPARMS void /* for empty parm lists */
-#endif
-
-/* function-pointer declarator */
-#ifndef FUNCPTR
-#if __STDC__ >= 1
-#define FUNCPTR(name, args) (*name)args
-#else
-#define FUNCPTR(name, args) (*name)()
-#endif
-#endif
-
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
#endif
#ifndef REALLOC
-#define REALLOC(p, n) realloc(VS(p), n)
+#define REALLOC(p, n) realloc(p, n)
#endif
#ifndef FREE
-#define FREE(p) free(VS(p))
+#define FREE(p) free(p)
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
@@ -96,7 +70,6 @@
*/
#define NOTREACHED 0
-#define xxx 1
#define DUPMAX _POSIX2_RE_DUP_MAX
#define DUPINF (DUPMAX+1)
@@ -408,7 +381,7 @@ struct subre {
*/
struct fns {
- void FUNCPTR(free, (regex_t *));
+ void (*free) (regex_t *);
};
/*
@@ -425,7 +398,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
- int FUNCPTR(compare, (const chr *, const chr *, size_t));
+ int (*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 d20a945..a48ab02 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -32,7 +32,7 @@ declare 0 {
const char *version, const void *clientData)
}
declare 1 {
- CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
+ const char *Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -40,22 +40,22 @@ declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
- char *Tcl_Alloc(unsigned int size)
+ char *Tcl_Alloc(TCL_HASH_TYPE size)
}
declare 4 {
void Tcl_Free(char *ptr)
}
declare 5 {
- char *Tcl_Realloc(char *ptr, unsigned int size)
+ char *Tcl_Realloc(char *ptr, TCL_HASH_TYPE size)
}
declare 6 {
- char *Tcl_DbCkalloc(unsigned int size, const char *file, int line)
+ char *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
- char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
+ char *Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
@@ -65,7 +65,7 @@ declare 8 {
declare 9 unix {
void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
@@ -86,10 +86,10 @@ declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
- void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length)
+ void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
declare 17 {
- Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[])
+ Tcl_Obj *Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -104,29 +104,29 @@ declare 20 {
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 22 {
+declare 22 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line)
}
declare 23 {
- Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length,
- const char *file, int line)
+ Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
+ Tcl_Size numBytes, const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
- Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
+ Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line)
}
-declare 26 {
+declare 26 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
- Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length,
+ Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length,
const char *file, int line)
}
declare 29 {
@@ -142,8 +142,9 @@ declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *intPtr)
}
+# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 33 {
- unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
+ unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
@@ -152,9 +153,9 @@ declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
-declare 36 {
+declare 36 {deprecated {No longer in use, changed to macro}} {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr)
+ const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
@@ -187,7 +188,7 @@ declare 45 {
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 46 {
- int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index,
+ int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr)
}
declare 47 {
@@ -195,65 +196,65 @@ declare 47 {
int *lengthPtr)
}
declare 48 {
- int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
- int count, int objc, Tcl_Obj *const objv[])
+ int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first,
+ Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 49 {
+declare 49 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewBooleanObj(int intValue)
}
declare 50 {
- Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length)
+ Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
-declare 52 {
+declare 52 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
declare 53 {
- Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
+ Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 54 {
+declare 54 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
- Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
+ Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length)
}
-declare 57 {
+declare 57 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue)
}
declare 58 {
- unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes)
+ unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
- int numBytes)
+ Tcl_Size numBytes)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
-declare 61 {
+declare 61 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 {
- void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
+ void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 63 {
+declare 63 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
- void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
+ void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
declare 65 {
- void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
+ void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
-declare 66 {
+declare 66 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
-declare 67 {
+declare 67 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
int length)
}
@@ -268,7 +269,7 @@ declare 70 {
}
declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
@@ -282,10 +283,10 @@ declare 74 {
declare 75 {
int Tcl_AsyncReady(void)
}
-declare 76 {
+declare 76 {deprecated {No longer in use, changed to macro}} {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
-declare 77 {
+declare 77 {deprecated {Use Tcl_UtfBackslash}} {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
@@ -294,11 +295,12 @@ declare 78 {
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 80 {
- void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
+ void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData)
}
+# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
@@ -306,85 +308,85 @@ declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
- char *Tcl_Concat(int argc, CONST84 char *const *argv)
+ char *Tcl_Concat(Tcl_Size argc, const char *const *argv)
}
declare 84 {
- int Tcl_ConvertElement(const char *src, char *dst, int flags)
+ Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
- int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
+ Tcl_Size Tcl_ConvertCountedElement(const char *src, Tcl_Size length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd,
- Tcl_Interp *target, const char *targetCmd, int argc,
- CONST84 char *const *argv)
+ Tcl_Interp *target, const char *targetCmd, Tcl_Size argc,
+ const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd,
- Tcl_Interp *target, const char *targetCmd, int objc,
+ Tcl_Interp *target, const char *targetCmd, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
- const char *chanName, ClientData instanceData, int mask)
+ const char *chanName, void *instanceData, int mask)
}
declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
- Tcl_ChannelProc *proc, ClientData clientData)
+ Tcl_ChannelProc *proc, void *clientData)
}
declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 91 {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
- Tcl_CmdProc *proc, ClientData clientData,
+ Tcl_CmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
- Tcl_EventCheckProc *checkProc, ClientData clientData)
+ Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 93 {
- void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
-declare 95 {
+declare 95 {deprecated {}} {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
- Tcl_MathProc *proc, ClientData clientData)
+ Tcl_MathProc *proc, void *clientData)
}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
- Tcl_ObjCmdProc *proc, ClientData clientData,
+ Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
- Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
+ Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
- Tcl_TimerProc *proc, ClientData clientData)
+ Tcl_TimerProc *proc, void *clientData)
}
declare 99 {
- Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
- Tcl_CmdTraceProc *proc, ClientData clientData)
+ Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level,
+ Tcl_CmdTraceProc *proc, void *clientData)
}
declare 100 {
void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name)
}
declare 101 {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 103 {
int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName)
@@ -393,14 +395,14 @@ declare 104 {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
}
declare 105 {
- void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
+ void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, void *clientData)
}
declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
- Tcl_EventCheckProc *checkProc, ClientData clientData)
+ Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 107 {
- void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
@@ -412,7 +414,7 @@ declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
declare 111 {
- void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr)
+ void Tcl_DetachPids(Tcl_Size numPids, Tcl_Pid *pidPtr)
}
declare 112 {
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
@@ -422,16 +424,16 @@ declare 113 {
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
- Tcl_InterpDeleteProc *proc, ClientData clientData)
+ Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 115 {
int Tcl_DoOneEvent(int flags)
}
declare 116 {
- void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
+ void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData)
}
declare 117 {
- char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length)
+ char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, Tcl_Size length)
}
declare 118 {
char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
@@ -452,7 +454,7 @@ declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 124 {
- void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length)
+ void Tcl_DStringSetLength(Tcl_DString *dsPtr, Tcl_Size length)
}
declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
@@ -461,10 +463,10 @@ declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
- CONST84_RETURN char *Tcl_ErrnoId(void)
+ const char *Tcl_ErrnoId(void)
}
declare 128 {
- CONST84_RETURN char *Tcl_ErrnoMsg(int err)
+ const char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
@@ -472,11 +474,11 @@ declare 129 {
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
-declare 131 {
+declare 131 {deprecated {No longer in use, changed to macro}} {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 {
- void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
+ void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
@@ -513,8 +515,8 @@ declare 142 {
declare 143 {
void Tcl_Finalize(void)
}
-declare 144 {
- void Tcl_FindExecutable(const char *argv0)
+declare 144 {nostub {Don't use this function in a stub-enabled extension}} {
+ const char *Tcl_FindExecutable(const char *argv0)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
@@ -523,21 +525,21 @@ declare 145 {
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
-declare 147 {
+declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
- int *argcPtr, CONST84 char ***argvPtr)
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
+ int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
- ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
+ void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
@@ -545,20 +547,20 @@ declare 151 {
int *modePtr)
}
declare 152 {
- int Tcl_GetChannelBufferSize(Tcl_Channel chan)
+ Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
- ClientData *handlePtr)
+ void **handlePtr)
}
declare 154 {
- ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
+ void *Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
- CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
+ const char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -572,20 +574,20 @@ declare 159 {
Tcl_CmdInfo *infoPtr)
}
declare 160 {
- CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
+ const char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
- CONST84_RETURN char *Tcl_GetHostName(void)
+ const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp)
}
declare 164 {
- Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
+ Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
@@ -598,8 +600,8 @@ declare 166 {
# generic interface, so we include it here for compatibility reasons.
declare 167 unix {
- int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr)
+ int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID,
+ int forWriting, int checkUsage, void **filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
@@ -607,35 +609,35 @@ declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
- int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
+ Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
declare 170 {
- int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
+ Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
- Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *name)
+ Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
- CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
+ const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
-declare 175 {
- CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+declare 175 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
- CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
-declare 178 {
+declare 178 {deprecated {No longer in use, changed to macro}} {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 {
@@ -662,11 +664,11 @@ declare 185 {
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
- char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
+ char *Tcl_JoinPath(Tcl_Size argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
- int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr,
+ int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr,
int type)
}
@@ -676,16 +678,16 @@ declare 187 {
# }
declare 189 {
- Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode)
+ Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
-declare 190 {
+declare 190 {deprecated {}} {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
- Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
+ Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
- char *Tcl_Merge(int argc, CONST84 char *const *argv)
+ char *Tcl_Merge(Tcl_Size argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
@@ -702,8 +704,8 @@ declare 196 {
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
declare 197 {
- Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags)
+ Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, Tcl_Size argc,
+ const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
@@ -717,10 +719,10 @@ declare 199 {
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
- ClientData callbackData)
+ void *callbackData)
}
declare 201 {
- void Tcl_Preserve(ClientData data)
+ void Tcl_Preserve(void *data)
}
declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
@@ -729,13 +731,13 @@ declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
- CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
+ const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
- void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
+ void Tcl_QueueEvent(Tcl_Event *evPtr, int position)
}
declare 206 {
- int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
+ Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, Tcl_Size toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
@@ -764,23 +766,22 @@ declare 214 {
const char *pattern)
}
declare 215 {
- void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr, CONST84 char **endPtr)
+ void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index,
+ const char **startPtr, const char **endPtr)
}
declare 216 {
- void Tcl_Release(ClientData clientData)
+ void Tcl_Release(void *clientData)
}
declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 {
- int Tcl_ScanElement(const char *src, int *flagPtr)
+ Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
- int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
+ Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
-# Obsolete
-declare 220 {
+declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
@@ -791,10 +792,10 @@ declare 222 {
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
- Tcl_InterpDeleteProc *proc, ClientData clientData)
+ Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 224 {
- void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
+ void Tcl_SetChannelBufferSize(Tcl_Channel chan, Tcl_Size sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -813,11 +814,11 @@ declare 228 {
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
-declare 230 {
- void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+declare 230 {nostub {Don't use this function in a stub-enabled extension}} {
+ const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
}
declare 231 {
- int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
+ Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth)
}
declare 232 {
void Tcl_SetResult(Tcl_Interp *interp, char *result,
@@ -835,56 +836,55 @@ declare 235 {
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
-declare 237 {
- CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+declare 237 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
- CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
- CONST84_RETURN char *Tcl_SignalId(int sig)
+ const char *Tcl_SignalId(int sig)
}
declare 240 {
- CONST84_RETURN char *Tcl_SignalMsg(int sig)
+ const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr)
+ const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
- void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
+ void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
-declare 244 {
- void Tcl_StaticPackage(Tcl_Interp *interp, const char *prefix,
- Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+declare 244 {nostub {Don't use this function in a stub-enabled extension}} {
+ void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
+ Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
-declare 245 {
+declare 245 {deprecated {No longer in use, changed to macro}} {
int Tcl_StringMatch(const char *str, const char *pattern)
}
-# Obsolete
-declare 246 {
+declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
-declare 247 {
+declare 247 {deprecated {No longer in use, changed to macro}} {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_VarTraceProc *proc, ClientData clientData)
+ Tcl_VarTraceProc *proc, void *clientData)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
- int flags, Tcl_VarTraceProc *proc, ClientData clientData)
+ int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
- int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead)
+ Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
@@ -892,26 +892,26 @@ declare 251 {
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 253 {
+declare 253 {deprecated {No longer in use, changed to macro}} {
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
-declare 255 {
+declare 255 {deprecated {No longer in use, changed to macro}} {
void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_VarTraceProc *proc, ClientData clientData)
+ Tcl_VarTraceProc *proc, void *clientData)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
-declare 258 {
+declare 258 {deprecated {No longer in use, changed to macro}} {
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName, int flags)
}
@@ -922,20 +922,20 @@ declare 259 {
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
-declare 261 {
- ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
- int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
+declare 261 {deprecated {No longer in use, changed to macro}} {
+ void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
+ int flags, Tcl_VarTraceProc *procPtr, void *prevClientData)
}
declare 262 {
- ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
+ void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
- ClientData prevClientData)
+ void *prevClientData)
}
declare 263 {
- int Tcl_Write(Tcl_Channel chan, const char *s, int slen)
+ Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen)
}
declare 264 {
- void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
+ void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
@@ -944,47 +944,47 @@ declare 265 {
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
-declare 267 {
+declare 267 {deprecated {see TIP #422}} {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
-declare 268 {
+declare 268 {deprecated {see TIP #422}} {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
- CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
- CONST84 char **termPtr)
+ const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr)
}
-declare 271 {
- CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+declare 271 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
- CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
+ const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
-declare 273 {
+declare 273 {deprecated {No longer in use, changed to macro}} {
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 {
- CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+declare 274 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
-declare 275 {
+declare 275 {deprecated {see TIP #422}} {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
-declare 276 {
+declare 276 {deprecated {see TIP #422}} {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 {
+declare 278 {deprecated {see TIP #422}} {
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
@@ -1010,7 +1010,7 @@ declare 280 {
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
- const Tcl_ChannelType *typePtr, ClientData instanceData,
+ const Tcl_ChannelType *typePtr, void *instanceData,
int mask, Tcl_Channel prevChan)
}
declare 282 {
@@ -1038,43 +1038,43 @@ declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
- void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
- void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
-declare 290 {
+declare 290 {deprecated {Use Tcl_DiscardInterpState}} {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 {
- int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes,
+ int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes,
int flags)
}
declare 292 {
- int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
+ int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
- void Tcl_ExitThread(int status)
+ TCL_NORETURN void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- const char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr)
}
declare 297 {
void Tcl_FinalizeThread(void)
}
declare 298 {
- void Tcl_FinalizeNotifier(ClientData clientData)
+ void Tcl_FinalizeNotifier(void *clientData)
}
declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
@@ -1086,25 +1086,25 @@ declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
- CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
+ const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
- const void *tablePtr, int offset, const char *msg, int flags,
- int *indexPtr)
+ const void *tablePtr, Tcl_Size offset, const char *msg, int flags,
+ void *indexPtr)
}
declare 305 {
- void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
+ void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, Tcl_Size size)
}
declare 306 {
Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 307 {
- ClientData Tcl_InitNotifier(void)
+ void *Tcl_InitNotifier(void)
}
declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
@@ -1120,16 +1120,16 @@ declare 311 {
const Tcl_Time *timePtr)
}
declare 312 {
- int Tcl_NumUtfChars(const char *src, int length)
+ Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
- int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
- int charsToRead, int appendFlag)
+ Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
+ Tcl_Size charsToRead, int appendFlag)
}
-declare 314 {
+declare 314 {deprecated {Use Tcl_RestoreInterpState}} {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
-declare 315 {
+declare 315 {deprecated {Use Tcl_SaveInterpState}} {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 {
@@ -1144,53 +1144,53 @@ declare 318 {
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
- Tcl_QueuePosition position)
+ int position)
}
declare 320 {
- Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+ int Tcl_UniCharAtIndex(const char *src, Tcl_Size index)
}
declare 321 {
- Tcl_UniChar Tcl_UniCharToLower(int ch)
+ int Tcl_UniCharToLower(int ch)
}
declare 322 {
- Tcl_UniChar Tcl_UniCharToTitle(int ch)
+ int Tcl_UniCharToTitle(int ch)
}
declare 323 {
- Tcl_UniChar Tcl_UniCharToUpper(int ch)
+ int Tcl_UniCharToUpper(int ch)
}
declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
- CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
+ const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index)
}
declare 326 {
- int Tcl_UtfCharComplete(const char *src, int length)
+ int TclUtfCharComplete(const char *src, Tcl_Size length)
}
declare 327 {
- int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
+ Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
- CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
+ const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
- CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
+ const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
- CONST84_RETURN char *Tcl_UtfNext(const char *src)
+ const char *TclUtfNext(const char *src)
}
declare 331 {
- CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
+ const char *TclUtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- const char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr)
}
declare 334 {
int Tcl_UtfToLower(char *src)
@@ -1199,28 +1199,28 @@ declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
- int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr)
+ int Tcl_UtfToChar16(const char *src, unsigned short *chPtr)
}
declare 337 {
int Tcl_UtfToUpper(char *src)
}
declare 338 {
- int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen)
+ Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen)
}
declare 339 {
- int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
+ Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
-declare 341 {
- CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
+declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
+ const char *Tcl_GetDefaultEncodingDir(void)
}
-declare 342 {
+declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
- void Tcl_AlertNotifier(ClientData clientData)
+ void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
@@ -1247,25 +1247,25 @@ declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
- int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
+ Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
-declare 353 {
- int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
+declare 353 {deprecated {Use Tcl_UtfNcmp}} {
+ int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct,
unsigned long numChars)
}
declare 354 {
- char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
- int uniLength, Tcl_DString *dsPtr)
+ char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr)
}
declare 355 {
- Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
- int length, Tcl_DString *dsPtr)
+ unsigned short *Tcl_UtfToChar16DString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
-declare 357 {
+declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
@@ -1274,29 +1274,29 @@ declare 358 {
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
- const char *command, int length)
+ const char *command, Tcl_Size length)
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append,
+ const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start,
- int numBytes, int nested, Tcl_Parse *parsePtr)
+ Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr)
}
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append,
+ const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
@@ -1335,40 +1335,40 @@ declare 375 {
}
declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
- Tcl_Obj *textObj, int offset, int nmatches, int flags)
+ Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags)
}
declare 377 {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 {
- Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars)
+ Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars)
}
declare 379 {
- void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
- int numChars)
+ void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode,
+ Tcl_Size numChars)
}
declare 380 {
- int Tcl_GetCharLength(Tcl_Obj *objPtr)
+ Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
- Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+ int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
-declare 382 {
- Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
+declare 382 {deprecated {No longer in use, changed to macro}} {
+ unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
- Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
+ Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
}
declare 384 {
- void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
- int length)
+ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode,
+ Tcl_Size length)
}
declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
declare 386 {
- void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
+ void Tcl_SetNotifier(const Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
@@ -1380,8 +1380,8 @@ declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
- int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
+ int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
@@ -1391,15 +1391,15 @@ declare 392 {
}
declare 393 {
int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc,
- ClientData clientData, int stackSize, int flags)
+ void *clientData, Tcl_Size stackSize, int flags)
}
# Introduced in 8.3.2
declare 394 {
- int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
+ Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead)
}
declare 395 {
- int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen)
+ Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, Tcl_Size srcLen)
}
declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
@@ -1408,7 +1408,7 @@ declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
- CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
+ const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
@@ -1418,7 +1418,7 @@ declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
-declare 401 {
+declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
}
@@ -1434,7 +1434,7 @@ declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
-declare 405 {
+declare 405 {deprecated {Use Tcl_ChannelWideSeekProc}} {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
}
@@ -1485,13 +1485,13 @@ declare 417 {
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
-declare 419 {
- int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
+declare 419 {deprecated {Use Tcl_UtfNcasecmp}} {
+ int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct,
unsigned long numChars)
}
-declare 420 {
- int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
- const Tcl_UniChar *uniPattern, int nocase)
+declare 420 {deprecated {Use Tcl_StringCaseMatch}} {
+ int Tcl_UniCharCaseMatch(const unsigned short *uniStr,
+ const unsigned short *uniPattern, int nocase)
}
declare 421 {
Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key)
@@ -1508,33 +1508,33 @@ declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
- ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
+ void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
- ClientData prevClientData)
+ void *prevClientData)
}
declare 426 {
int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_CommandTraceProc *proc, ClientData clientData)
+ Tcl_CommandTraceProc *proc, void *clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
- int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
+ int flags, Tcl_CommandTraceProc *proc, void *clientData)
}
declare 428 {
- char *Tcl_AttemptAlloc(unsigned int size)
+ char *Tcl_AttemptAlloc(TCL_HASH_TYPE size)
}
declare 429 {
- char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line)
+ char *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 430 {
- char *Tcl_AttemptRealloc(char *ptr, unsigned int size)
+ char *Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size)
}
declare 431 {
- char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
+ char *Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
declare 432 {
- int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
+ int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
# TIP#10 (thread-aware channels) akupries
@@ -1544,16 +1544,16 @@ declare 433 {
# introduced in 8.4a3
declare 434 {
- Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
+ unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
-declare 435 {
+declare 435 {deprecated {}} {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
- Tcl_MathProc **procPtr, ClientData *clientDataPtr)
+ Tcl_MathProc **procPtr, void **clientDataPtr)
}
-declare 436 {
+declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
@@ -1584,8 +1584,8 @@ declare 443 {
}
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,
+ const char *sym2, Tcl_LibraryInitProc **proc1Ptr,
+ Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 {
@@ -1640,7 +1640,7 @@ declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 460 {
- Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
+ Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements)
}
declare 461 {
Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr)
@@ -1652,11 +1652,11 @@ declare 463 {
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
- Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
+ Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 465 {
- ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
+ void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
}
declare 466 {
@@ -1667,7 +1667,7 @@ declare 467 {
}
declare 468 {
Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem,
- ClientData clientData)
+ void *clientData)
}
declare 469 {
const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
@@ -1682,13 +1682,13 @@ declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
declare 473 {
- int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr)
+ int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr)
}
declare 474 {
int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr)
}
declare 475 {
- ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr)
+ void *Tcl_FSData(const Tcl_Filesystem *fsPtr)
}
declare 476 {
const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
@@ -1712,7 +1712,7 @@ declare 480 {
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
- int count)
+ Tcl_Size count)
}
# TIP#73 (access to current time) kbk
@@ -1722,8 +1722,8 @@ declare 482 {
# TIP#32 (object-enabled traces) kbk
declare 483 {
- Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
- Tcl_CmdObjTraceProc *objProc, ClientData clientData,
+ Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc *objProc, void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 484 {
@@ -1754,10 +1754,10 @@ declare 490 {
Tcl_StatBuf *Tcl_AllocStatBuf(void)
}
declare 491 {
- Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
+ long long Tcl_Seek(Tcl_Channel chan, long long offset, int mode)
}
declare 492 {
- Tcl_WideInt Tcl_Tell(Tcl_Channel chan)
+ long long Tcl_Tell(Tcl_Channel chan)
}
# TIP#91 (back-compat enhancements for channels) dkf
@@ -1798,11 +1798,11 @@ declare 500 {
}
declare 501 {
int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
+ Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
}
declare 502 {
int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *const *keyv)
+ Tcl_Size keyc, Tcl_Obj *const *keyv)
}
declare 503 {
Tcl_Obj *Tcl_NewDictObj(void)
@@ -1821,7 +1821,7 @@ declare 505 {
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
- ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
+ void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 507 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
@@ -1871,19 +1871,19 @@ declare 518 {
}
# TIP#121 (exit handler) dkf for Joe Mistachkin
-declare 519 {
+declare 519 {nostub {Don't use this function in a stub-enabled extension}} {
Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
- Tcl_LimitHandlerProc *handlerProc, ClientData clientData,
+ Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
declare 521 {
void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
- Tcl_LimitHandlerProc *handlerProc, ClientData clientData)
+ Tcl_LimitHandlerProc *handlerProc, void *clientData)
}
declare 522 {
int Tcl_LimitReady(Tcl_Interp *interp)
@@ -1895,7 +1895,7 @@ declare 524 {
int Tcl_LimitExceeded(Tcl_Interp *interp)
}
declare 525 {
- void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit)
+ void Tcl_LimitSetCommands(Tcl_Interp *interp, Tcl_Size commandLimit)
}
declare 526 {
void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr)
@@ -1996,12 +1996,12 @@ declare 551 {
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
- ClientData clientData)
+ void *clientData)
}
declare 553 {
void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
- ClientData *clientData)
+ void **clientData)
}
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
@@ -2012,24 +2012,24 @@ declare 554 {
# TIP#237 (arbitrary-precision integers) kbk
declare 555 {
- Tcl_Obj *Tcl_NewBignumObj(mp_int *value)
+ Tcl_Obj *Tcl_NewBignumObj(void *value)
}
declare 556 {
- Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, const char *file, int line)
+ Tcl_Obj *Tcl_DbNewBignumObj(void *value, const char *file, int line)
}
declare 557 {
- void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value)
+ void Tcl_SetBignumObj(Tcl_Obj *obj, void *value)
}
declare 558 {
- int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
+ int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
declare 559 {
- int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
+ int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
# TIP #208 ('chan' command) jeffh
declare 560 {
- int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
+ int Tcl_TruncateChannel(Tcl_Channel chan, long long length)
}
declare 561 {
Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
@@ -2053,7 +2053,7 @@ declare 565 {
# TIP #237 (additional conversion functions for bignum support) kbk/dgp
declare 566 {
int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval,
- mp_int *toInit)
+ void *toInit)
}
# TIP#181 (namespace unknown command) dgp for Neil Madden
@@ -2084,7 +2084,7 @@ declare 572 {
# TIP#268 (extended version numbers and requirements) akupries
declare 573 {
int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
- int objc, Tcl_Obj *const objv[], void *clientDataPtr)
+ Tcl_Size objc, Tcl_Obj *const objv[], void *clientDataPtr)
}
# TIP#270 (utility C routines for string formatting) dgp
@@ -2093,15 +2093,15 @@ declare 574 {
}
declare 575 {
void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes,
- int length, int limit, const char *ellipsis)
+ Tcl_Size length, Tcl_Size limit, const char *ellipsis)
}
declare 576 {
- Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc,
+ Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- const char *format, int objc, Tcl_Obj *const objv[])
+ const char *format, Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 578 {
Tcl_Obj *Tcl_ObjPrintf(const char *format, ...)
@@ -2115,7 +2115,7 @@ declare 579 {
# TIP #285 (script cancellation support) jmistachkin
declare 580 {
int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
- ClientData clientData, int flags)
+ void *clientData, int flags)
}
declare 581 {
int Tcl_Canceled(Tcl_Interp *interp, int flags)
@@ -2131,30 +2131,30 @@ declare 582 {
declare 583 {
Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- Tcl_ObjCmdProc *nreProc, ClientData clientData,
+ Tcl_ObjCmdProc *nreProc, void *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)
+ int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size objc,
+ Tcl_Obj *const objv[], int flags)
}
declare 586 {
- int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc,
+ int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size 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)
+ void *data0, void *data1, void *data2,
+ void *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[])
+ void *clientData, Tcl_Size objc, Tcl_Obj *const objv[])
}
# TIP#316 (Tcl_StatBuf reader functions) dkf
@@ -2180,19 +2180,19 @@ declare 595 {
int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr)
}
declare 596 {
- Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 597 {
- Tcl_WideInt Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 598 {
- Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 599 {
- Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr)
+ unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr)
}
declare 600 {
- Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr)
+ unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr)
}
declare 601 {
unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr)
@@ -2245,15 +2245,15 @@ declare 610 {
}
declare 611 {
int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
- int buffersize, Tcl_Obj *gzipHeaderDictObj)
+ Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj)
}
declare 612 {
unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf,
- int len)
+ Tcl_Size len)
}
declare 613 {
unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf,
- int len)
+ Tcl_Size len)
}
declare 614 {
int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format,
@@ -2272,7 +2272,8 @@ 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)
+ int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data,
+ Tcl_Size count)
}
declare 620 {
int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle)
@@ -2326,12 +2327,248 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
-declare 687 {
- void TclUnusedStubEntry(void)
+# TIP #456/#468
+declare 631 {
+ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
+ const char *host, unsigned int flags, int backlog,
+ Tcl_TcpAcceptProc *acceptProc, void *callbackData)
+}
+
+# TIP #430
+declare 632 {
+ int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint,
+ const char *zipname, const char *passwd)
+}
+declare 633 {
+ int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint)
+}
+declare 634 {
+ Tcl_Obj *TclZipfs_TclLibrary(void)
+}
+declare 635 {
+ int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint,
+ unsigned char *data, size_t datalen, int copy)
+}
+
+# TIP #445
+declare 636 {
+ void Tcl_FreeInternalRep(Tcl_Obj *objPtr)
+}
+declare 637 {
+ char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ TCL_HASH_TYPE numBytes)
+}
+declare 638 {
+ Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
+}
+declare 639 {
+ void Tcl_StoreInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
+ const Tcl_ObjInternalRep *irPtr)
+}
+declare 640 {
+ int Tcl_HasStringRep(Tcl_Obj *objPtr)
+}
+
+# TIP #506
+declare 641 {
+ void Tcl_IncrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 642 {
+ void Tcl_DecrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 643 {
+ int Tcl_IsShared(Tcl_Obj *objPtr)
+}
+
+# TIP#312 New Tcl_LinkArray() function
+declare 644 {
+ int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
+ int type, Tcl_Size size)
+}
+
+declare 645 {
+ int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Size endValue, Tcl_Size *indexPtr)
+}
+
+# TIP #548
+declare 646 {
+ int Tcl_UtfToUniChar(const char *src, int *chPtr)
+}
+declare 647 {
+ char *Tcl_UniCharToUtfDString(const int *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr)
+}
+declare 648 {
+ int *Tcl_UtfToUniCharDString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr)
+}
+
+# TIP #568
+declare 649 {
+ unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int *numBytesPtr)
+}
+declare 650 {
+ unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ size_t *numBytesPtr)
+}
+
+# TIP #481
+declare 651 {
+ char *TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
+}
+declare 652 {
+ unsigned short *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
+}
+# Only available in Tcl 8.x, NULL in Tcl 9.0
+declare 653 {
+ unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr)
+}
+
+# TIP #575
+declare 654 {
+ int Tcl_UtfCharComplete(const char *src, Tcl_Size length)
+}
+declare 655 {
+ const char *Tcl_UtfNext(const char *src)
+}
+declare 656 {
+ const char *Tcl_UtfPrev(const char *src, const char *start)
+}
+declare 657 {
+ int Tcl_UniCharIsUnicode(int ch)
+}
+declare 658 {
+ Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr)
+}
+declare 659 {
+ Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr)
+}
+
+# TIP #511
+declare 660 {
+ int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
+}
+
+# TIP #616
+declare 661 {
+ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ size_t *objcPtr, Tcl_Obj ***objvPtr)
+}
+declare 662 {
+ int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ size_t *lengthPtr)
+}
+declare 663 {
+ int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr)
+}
+declare 664 {
+ int TclSplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr,
+ const char ***argvPtr)
+}
+declare 665 {
+ void TclSplitPath(const char *path, size_t *argcPtr, const char ***argvPtr)
+}
+declare 666 {
+ Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr)
+}
+declare 667 {
+ int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
+ size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
+}
+
+# TIP #617
+declare 668 {
+ Tcl_Size Tcl_UniCharLen(const int *uniStr)
+}
+declare 669 {
+ Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
+}
+declare 670 {
+ Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
+}
+declare 671 {
+ const char *TclUtfAtIndex(const char *src, Tcl_Size index)
+}
+declare 672 {
+ Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
+}
+declare 673 {
+ int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
+}
+
+declare 674 {
+ int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags,
+ char *charPtr)
+}
+declare 675 {
+ int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags, char *charPtr)
+}
+declare 676 {
+ Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_ObjCmdProc2 *proc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 677 {
+ Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc2 *objProc2, void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc)
+}
+declare 678 {
+ Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 679 {
+ int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
+ void *clientData, size_t objc, Tcl_Obj *const objv[])
+}
+
+# TIP #638.
+declare 680 {
+ int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ void **clientDataPtr, int *typePtr)
+}
+declare 681 {
+ int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, size_t numBytes,
+ void **clientDataPtr, int *typePtr)
+}
+
+# TIP #220.
+declare 682 {
+ int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
+}
+
+# TIP 643
+declare 683 {
+ Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding)
+}
+
+# TIP #650
+declare 684 {
+ int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideUInt *uwidePtr)
+}
+
+# TIP 651
+declare 685 {
+ Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
+declare 687 {
+ void TclUnusedStubEntry(void)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
@@ -2355,7 +2592,7 @@ declare 1 win {
char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr)
}
declare 3 win {
- void TclUnusedStubEntry(void)
+ void Tcl_WinConvertError(unsigned errCode)
}
################################
@@ -2372,7 +2609,7 @@ declare 1 macosx {
int hasResourceFile, int maxPathLen, char *libraryPath)
}
declare 2 macosx {
- void TclUnusedStubEntry(void)
+ void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
##############################################################################
@@ -2380,13 +2617,26 @@ declare 2 macosx {
# Public functions that are not accessible via the stubs table.
export {
- void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
+ void Tcl_Main(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
- void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc,
+ void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc,
Tcl_Interp *interp)
}
export {
+ void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
+ Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
+}
+export {
+ const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+}
+export {
+ Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
+}
+export {
+ const char *Tcl_FindExecutable(const char *argv0)
+}
+export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
@@ -2401,6 +2651,12 @@ export {
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
+export {
+ const char *Tcl_InitSubsystems(void)
+}
+export {
+ const char *TclZipfs_AppHook(int *argc, char ***argv)
+}
# Local Variables:
diff --git a/generic/tcl.h b/generic/tcl.h
index 8b7c4ed..f373382 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -38,24 +38,29 @@ extern "C" {
* update the version numbers:
*
* library/init.tcl (1 LOC patch)
- * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
- * win/configure.in (as above)
+ * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch)
+ * win/configure.ac (as above)
* win/tcl.m4 (not patchlevel)
* README (sections 0 and 2, with and without separator)
* macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC
* win/README (not patchlevel) (sections 0 and 2)
* unix/tcl.spec (1 LOC patch)
- * tools/tcl.hpj.in (not patchlevel, for windows installer)
*/
-#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 6
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 13
+#if !defined(TCL_MAJOR_VERSION)
+# define TCL_MAJOR_VERSION 8
+#endif
+#if TCL_MAJOR_VERSION != 8
+# error "This header-file is for Tcl 8 only"
+#endif
+#define TCL_MINOR_VERSION 7
+#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE
+#define TCL_RELEASE_SERIAL 6
-#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.13"
+#define TCL_VERSION "8.7"
+#define TCL_PATCH_LEVEL "8.7a6"
+#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED)
/*
*----------------------------------------------------------------------------
* The following definitions set up the proper options for Windows compilers.
@@ -85,6 +90,11 @@ extern "C" {
# define JOIN1(a,b) a##b
#endif
+#ifndef TCL_THREADS
+# define TCL_THREADS 1
+#endif
+#endif /* !TCL_NO_DEPRECATED */
+
/*
* A special definition used to allow this header file to be included from
* windows resource files so that they can obtain version information.
@@ -97,15 +107,10 @@ extern "C" {
#ifndef RC_INVOKED
/*
- * Special macro to define mutexes, that doesn't do anything if we are not
- * using threads.
+ * Special macro to define mutexes.
*/
-#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
-#else
-#define TCL_DECLARE_MUTEX(name)
-#endif
/*
* Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
@@ -143,6 +148,7 @@ extern "C" {
# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
# endif
# define TCL_NORETURN __attribute__ ((noreturn))
+# define TCL_NOINLINE __attribute__ ((noinline))
# if defined(BUILD_tcl) || defined(BUILD_tk)
# define TCL_NORETURN1 __attribute__ ((noreturn))
# else
@@ -150,10 +156,12 @@ extern "C" {
# endif
#else
# define TCL_FORMAT_PRINTF(a,b)
-# if defined(_MSC_VER) && (_MSC_VER >= 1310)
+# if defined(_MSC_VER)
# define TCL_NORETURN _declspec(noreturn)
+# define TCL_NOINLINE __declspec(noinline)
# else
# define TCL_NORETURN /* nothing */
+# define TCL_NOINLINE /* nothing */
# endif
# define TCL_NORETURN1 /* nothing */
#endif
@@ -189,8 +197,7 @@ extern "C" {
* MSVCRT.
*/
-#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
-# define HAVE_DECLSPEC 1
+#ifdef _WIN32
# ifdef STATIC_BUILD
# define DLLIMPORT
# define DLLEXPORT
@@ -249,10 +256,9 @@ extern "C" {
* New code should use prototypes.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
-#endif
/*
* Definitions that allow this header file to be used either with or without
@@ -262,34 +268,14 @@ extern "C" {
#ifndef INLINE
# define INLINE
#endif
-
-#ifdef NO_CONST
-# ifndef const
-# define const
-# endif
-#endif
#ifndef CONST
# define CONST const
#endif
-#ifdef USE_NON_CONST
-# ifdef USE_COMPAT_CONST
-# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
-# endif
-# define CONST84
-# define CONST84_RETURN
-#else
-# ifdef USE_COMPAT_CONST
-# define CONST84
-# define CONST84_RETURN const
-# else
-# define CONST84 const
-# define CONST84_RETURN const
-# endif
-#endif
+#endif /* !TCL_NO_DEPRECATED */
#ifndef CONST86
-# define CONST86 CONST84
+# define CONST86 const
#endif
/*
@@ -313,6 +299,7 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
@@ -328,25 +315,15 @@ typedef long LONG;
*/
#ifndef __VXWORKS__
-# ifndef NO_VOID
-# define VOID void
-# else
-# define VOID char
-# endif
+# define VOID void
#endif
+#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */
/*
* Miscellaneous declarations.
*/
-#ifndef _CLIENTDATA
-# ifndef NO_VOID
- typedef void *ClientData;
-# else
- typedef int *ClientData;
-# endif
-# define _CLIENTDATA
-#endif
+typedef void *ClientData;
/*
* Darwin specific configure overrides (to support fat compiles, where
@@ -355,11 +332,9 @@ typedef long LONG;
#ifdef __APPLE__
# ifdef __LP64__
-# undef TCL_WIDE_INT_TYPE
# define TCL_WIDE_INT_IS_LONG 1
# define TCL_CFG_DO64BIT 1
# else /* !__LP64__ */
-# define TCL_WIDE_INT_TYPE long long
# undef TCL_WIDE_INT_IS_LONG
# undef TCL_CFG_DO64BIT
# endif /* __LP64__ */
@@ -371,8 +346,6 @@ typedef long LONG;
*/
#if defined(__GNUC__) && !defined(_WIN32) && !defined(__LP64__)
# undef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long long
#endif
/*
@@ -390,78 +363,61 @@ typedef long LONG;
*
* The following invariant should hold for any long value 'longVal':
* longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
- *
- * Note on converting between Tcl_WideInt and strings. This implementation (in
- * tclObj.c) depends on the function
- * sprintf(...,"%" TCL_LL_MODIFIER "d",...).
- */
-
-#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
-# ifdef _WIN32
-# define TCL_WIDE_INT_TYPE __int64
-# ifdef __BORLANDC__
-# define TCL_LL_MODIFIER "L"
-# elif defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO)
-# define TCL_LL_MODIFIER "I64"
-# else
-# define TCL_LL_MODIFIER "ll"
-# endif
-# elif defined(__GNUC__)
-# define TCL_WIDE_INT_TYPE long long
-# define TCL_LL_MODIFIER "ll"
-# else /* ! _WIN32 && ! __GNUC__ */
+ */
+
+#if !defined(TCL_WIDE_INT_TYPE) && !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__GNUC__)
/*
* Don't know what platform it is and configure hasn't discovered what is
* going on for us. Try to guess...
*/
-# include <limits.h>
-# if (INT_MAX < LONG_MAX)
-# define TCL_WIDE_INT_IS_LONG 1
-# else
-# define TCL_WIDE_INT_TYPE long long
-# endif
-# endif /* _WIN32 */
-#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
-#ifdef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long
-#endif /* TCL_WIDE_INT_IS_LONG */
+# include <limits.h>
+# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX)
+# define TCL_WIDE_INT_IS_LONG 1
+# endif
+#endif
+
+#ifndef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long long
+#endif /* !TCL_WIDE_INT_TYPE */
typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
-#ifdef TCL_WIDE_INT_IS_LONG
-# define Tcl_WideAsLong(val) ((long)(val))
-# define Tcl_LongAsWide(val) ((long)(val))
-# define Tcl_WideAsDouble(val) ((double)((long)(val)))
-# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "l"
-# endif /* !TCL_LL_MODIFIER */
-#else /* TCL_WIDE_INT_IS_LONG */
-/*
- * The next short section of defines are only done when not running on Windows
- * or some other strange platform.
- */
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "ll"
-# endif /* !TCL_LL_MODIFIER */
-# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
-# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
-# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
-# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
-#endif /* TCL_WIDE_INT_IS_LONG */
+#ifndef TCL_LL_MODIFIER
+# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO)
+# define TCL_LL_MODIFIER "I64"
+# else
+# define TCL_LL_MODIFIER "ll"
+# endif
+#endif /* !TCL_LL_MODIFIER */
+#ifndef TCL_Z_MODIFIER
+# if defined(__GNUC__) && !defined(_WIN32)
+# define TCL_Z_MODIFIER "z"
+# elif defined(_WIN64)
+# define TCL_Z_MODIFIER TCL_LL_MODIFIER
+# else
+# define TCL_Z_MODIFIER ""
+# endif
+#endif /* !TCL_Z_MODIFIER */
+#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
+#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
+#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
+#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
+
+#if TCL_MAJOR_VERSION > 8
+typedef size_t Tcl_Size;
+#else
+typedef int Tcl_Size;
+#endif
#ifdef _WIN32
-# ifdef __BORLANDC__
- typedef struct stati64 Tcl_StatBuf;
-# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T)
+# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
typedef struct __stat64 Tcl_StatBuf;
-# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
+# elif defined(_USE_32BIT_TIME_T)
typedef struct _stati64 Tcl_StatBuf;
# else
typedef struct _stat32i64 Tcl_StatBuf;
-# endif /* _MSC_VER < 1400 */
+# endif
#elif defined(__CYGWIN__)
typedef struct {
unsigned st_dev;
@@ -509,31 +465,9 @@ typedef struct Tcl_Interp
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
-#ifdef USE_INTERP_RESULT
- char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* If the last command returned a string
- * result, this points to it. */
- void (*freeProc) (char *blockPtr)
- TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* Zero means the string result is statically
- * allocated. TCL_DYNAMIC means it was
- * allocated with ckalloc and should be freed
- * with ckfree. Other values give the address
- * of function to invoke to free the result.
- * Tcl_Eval must free it before executing next
- * command. */
-#else
char *resultDontUse; /* Don't use in extensions! */
void (*freeProcDontUse) (char *); /* Don't use in extensions! */
-#endif
-#ifdef USE_INTERP_ERRORLINE
- int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine");
- /* When TCL_ERROR is returned, this gives the
- * line number within the command where the
- * error occurred (1 if first line). */
-#else
int errorLineDontUse; /* Don't use in extensions! */
-#endif
}
#endif /* !TCL_NO_DEPRECATED */
Tcl_Interp;
@@ -567,9 +501,9 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream;
*/
#if defined _WIN32
-typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
+typedef unsigned (__stdcall Tcl_ThreadCreateProc) (void *clientData);
#else
-typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
+typedef void (Tcl_ThreadCreateProc) (void *clientData);
#endif
/*
@@ -685,7 +619,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -701,6 +637,7 @@ typedef struct stat *Tcl_OldStat_;
* Argument descriptors for math function callbacks in expressions:
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
@@ -712,6 +649,10 @@ typedef struct Tcl_Value {
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
+#else
+#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */
+#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */
+#endif
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
@@ -726,64 +667,74 @@ struct Tcl_Obj;
*/
typedef int (Tcl_AppInitProc) (Tcl_Interp *interp);
-typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_AsyncProc) (void *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,
+typedef void (Tcl_ChannelProc) (void *clientData, int mask);
+typedef void (Tcl_CloseProc) (void *data);
+typedef void (Tcl_CmdDeleteProc) (void *clientData);
+typedef int (Tcl_CmdProc) (void *clientData, Tcl_Interp *interp,
+ int argc, const char *argv[]);
+typedef void (Tcl_CmdTraceProc) (void *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,
+ void *cmdClientData, int argc, const char *argv[]);
+typedef int (Tcl_CmdObjTraceProc) (void *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 int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp,
+ size_t level, const char *command, Tcl_Command commandInfo, size_t objc,
+ struct Tcl_Obj *const *objv);
+typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr);
-typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src,
+typedef int (Tcl_EncodingConvertProc) (void *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 void (Tcl_EncodingFreeProc) (void *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_EventCheckProc) (void *clientData, int flags);
+typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData);
+typedef void (Tcl_EventSetupProc) (void *clientData, int flags);
+typedef void (Tcl_ExitProc) (void *clientData);
+typedef void (Tcl_FileProc) (void *clientData, int mask);
+typedef void (Tcl_FileFreeProc) (void *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,
+typedef void (Tcl_IdleProc) (void *clientData);
+typedef void (Tcl_InterpDeleteProc) (void *clientData,
Tcl_Interp *interp);
-typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_MathProc) (void *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,
+typedef void (Tcl_NamespaceDeleteProc) (void *clientData);
+typedef int (Tcl_ObjCmdProc) (void *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 int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp,
+ size_t objc, struct Tcl_Obj *const *objv);
+typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp);
+typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
-typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan,
+typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan,
char *address, int port);
-typedef void (Tcl_TimerProc) (ClientData clientData);
+typedef void (Tcl_TimerProc) (void *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,
+typedef char * (Tcl_VarTraceProc) (void *clientData, Tcl_Interp *interp,
+ const char *part1, const char *part2, int flags);
+typedef void (Tcl_CommandTraceProc) (void *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);
+ void *clientData);
typedef void (Tcl_DeleteFileHandlerProc) (int fd);
-typedef void (Tcl_AlertNotifierProc) (ClientData clientData);
+typedef void (Tcl_AlertNotifierProc) (void *clientData);
typedef void (Tcl_ServiceModeHookProc) (int mode);
-typedef ClientData (Tcl_InitNotifierProc) (void);
-typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData);
+typedef void *(Tcl_InitNotifierProc) (void);
+typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
-
+
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_PackageInitProc Tcl_LibraryInitProc
+# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
+#endif
+
/*
*----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
@@ -808,6 +759,30 @@ typedef struct Tcl_ObjType {
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
} Tcl_ObjType;
+#define TCL_OBJTYPE_V0 /* just empty */
+
+/*
+ * The following structure stores an internal representation (internalrep) for
+ * a Tcl value. An internalrep is associated with an Tcl_ObjType when both
+ * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
+ * the handling of the internalrep.
+ */
+
+typedef union Tcl_ObjInternalRep { /* The internal representation: */
+ long longValue; /* - an long integer value. */
+ double doubleValue; /* - a double-precision floating value. */
+ void *otherValuePtr; /* - another, type-specific value, */
+ /* not used internally any more. */
+ Tcl_WideInt wideValue; /* - an integer value >= 64bits */
+ struct { /* - internal rep as two pointers. */
+ void *ptr1;
+ void *ptr2;
+ } twoPtrValue;
+ struct { /* - internal rep as a pointer and a long, */
+ void *ptr; /* not used internally any more. */
+ unsigned long value;
+ } ptrAndLongRep;
+} Tcl_ObjInternalRep;
/*
* One of the following structures exists for each object in the Tcl system.
@@ -816,7 +791,7 @@ typedef struct Tcl_ObjType {
*/
typedef struct Tcl_Obj {
- int refCount; /* When 0 the object will be freed. */
+ Tcl_Size refCount; /* When 0 the object will be freed. */
char *bytes; /* This points to the first byte of the
* object's string representation. The array
* must be followed by a null byte (i.e., at
@@ -828,45 +803,15 @@ typedef struct Tcl_Obj {
* should use Tcl_GetStringFromObj or
* Tcl_GetString to get a pointer to the byte
* array as a readonly value. */
- int length; /* The number of bytes at *bytes, not
+ Tcl_Size length; /* The number of bytes at *bytes, not
* including the terminating null. */
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,
- not used internally any more. */
- Tcl_WideInt wideValue; /* - a long long value. */
- struct { /* - internal rep as two pointers.
- * the main use of which is a bignum's
- * tightly packed fields, where the alloc,
- * used and signum flags are packed into
- * ptr2 with everything else hung off ptr1. */
- void *ptr1;
- void *ptr2;
- } twoPtrValue;
- struct { /* - internal rep as a pointer and a long,
- not used internally any more. */
- void *ptr;
- unsigned long value;
- } ptrAndLongRep;
- } internalRep;
+ Tcl_ObjInternalRep internalRep; /* The internal representation: */
} Tcl_Obj;
-/*
- * Macros to increment and decrement a Tcl_Obj's reference count, and to test
- * whether an object is shared (i.e. has reference count > 1). Note: clients
- * should use Tcl_DecrRefCount() when they are finished using an object, and
- * should never call TclFreeObj() directly. TclFreeObj() is only defined and
- * made public in tcl.h to support Tcl_DecrRefCount's macro definition.
- */
-
-void Tcl_IncrRefCount(Tcl_Obj *objPtr);
-void Tcl_DecrRefCount(Tcl_Obj *objPtr);
-int Tcl_IsShared(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------------------
@@ -875,6 +820,7 @@ int Tcl_IsShared(Tcl_Obj *objPtr);
* typically allocated on the stack.
*/
+#ifndef TCL_NO_DEPRECATED
typedef struct Tcl_SavedResult {
char *result;
Tcl_FreeProc *freeProc;
@@ -882,8 +828,9 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
+#endif
/*
*----------------------------------------------------------------------------
@@ -899,7 +846,7 @@ typedef struct Tcl_Namespace {
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
- ClientData clientData; /* Arbitrary value associated with this
+ void *clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Function invoked when deleting the
@@ -936,14 +883,14 @@ typedef struct Tcl_Namespace {
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
- int dummy2;
+ Tcl_Size dummy2;
void *dummy3;
void *dummy4;
void *dummy5;
- int dummy6;
+ Tcl_Size dummy6;
void *dummy7;
void *dummy8;
- int dummy9;
+ Tcl_Size dummy9;
void *dummy10;
void *dummy11;
void *dummy12;
@@ -967,23 +914,25 @@ typedef struct Tcl_CallFrame {
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
- * Tcl_CreateObjCommand; 0 otherwise.
- * Tcl_SetCmdInfo does not modify this
- * field. */
+ * Tcl_CreateObjCommand; 2 if objProc was registered by
+ * a call to Tcl_CreateObjCommand2; 0 otherwise.
+ * Tcl_SetCmdInfo does not modify this field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
- ClientData objClientData; /* ClientData for object proc. */
+ void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
- ClientData clientData; /* ClientData for string proc. */
+ void *clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
- ClientData deleteData; /* Value to pass to deleteProc (usually the
+ void *deleteData; /* Value to pass to deleteProc (usually the
* same as clientData). */
Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
* command. Note that Tcl_SetCmdInfo will not
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
+ Tcl_ObjCmdProc2 *objProc2; /* Not used in Tcl 8.7. */
+ void *objClientData2; /* Not used in Tcl 8.7. */
} Tcl_CmdInfo;
/*
@@ -997,9 +946,9 @@ typedef struct Tcl_CmdInfo {
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* staticSpace below or a malloced array. */
- int length; /* Number of non-NULL characters in the
+ Tcl_Size length; /* Number of non-NULL characters in the
* string. */
- int spaceAvl; /* Total number of bytes available for the
+ Tcl_Size spaceAvl; /* Total number of bytes available for the
* string and its terminating NULL char. */
char staticSpace[TCL_DSTRING_STATIC_SIZE];
/* Space to use in common case where string is
@@ -1008,12 +957,14 @@ typedef struct Tcl_DString {
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
-#define Tcl_DStringTrunc Tcl_DStringSetLength
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define Tcl_DStringTrunc Tcl_DStringSetLength
+#endif /* !TCL_NO_DEPRECATED */
/*
* Definitions for the maximum number of digits of precision that may be
- * specified in the "tcl_precision" variable, and the number of bytes of
- * buffer space required by Tcl_PrintDouble.
+ * produced by Tcl_PrintDouble, and the number of bytes of buffer space
+ * required by Tcl_PrintDouble.
*/
#define TCL_MAX_PREC 17
@@ -1025,7 +976,21 @@ typedef struct Tcl_DString {
* 64-bit integers).
*/
-#define TCL_INTEGER_SPACE 24
+#define TCL_INTEGER_SPACE (3*(int)sizeof(Tcl_WideInt))
+
+/*
+ *----------------------------------------------------------------------------
+ * Type values returned by Tcl_GetNumberFromObj
+ * TCL_NUMBER_INT Representation is a Tcl_WideInt
+ * TCL_NUMBER_BIG Representation is an mp_int
+ * TCL_NUMBER_DOUBLE Representation is a double
+ * TCL_NUMBER_NAN Value is NaN.
+ */
+
+#define TCL_NUMBER_INT 2
+#define TCL_NUMBER_BIG 3
+#define TCL_NUMBER_DOUBLE 4
+#define TCL_NUMBER_NAN 5
/*
* Flag values passed to Tcl_ConvertElement.
@@ -1041,13 +1006,29 @@ typedef struct Tcl_DString {
#define TCL_DONT_QUOTE_HASH 8
/*
- * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
- * abbreviated strings.
+ * Flags that may be passed to Tcl_GetIndexFromObj.
+ * TCL_EXACT disallows abbreviated strings.
+ * TCL_NULL_OK allows the empty string or NULL to return TCL_OK.
+ * The returned value will be -1;
+ * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is
+ * a table that will not live long enough to make it worthwhile.
*/
-#define TCL_EXACT 1
+#define TCL_EXACT 1
+#define TCL_NULL_OK 32
+#define TCL_INDEX_TEMP_TABLE 64
/*
+ * Flags that may be passed to Tcl_UniCharToUtf.
+ * TCL_COMBINE Combine surrogates (default in Tcl 8.x)
+ */
+
+#if TCL_MAJOR_VERSION > 8
+# define TCL_COMBINE 0x1000000
+#else
+# define TCL_COMBINE 0
+#endif
+/*
*----------------------------------------------------------------------------
* Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
* WARNING: these bit choices must not conflict with the bit choices for
@@ -1099,7 +1080,11 @@ typedef struct Tcl_DString {
#define TCL_TRACE_WRITES 0x20
#define TCL_TRACE_UNSETS 0x40
#define TCL_TRACE_DESTROYED 0x80
+
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_INTERP_DESTROYED 0x100
+#endif
+
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
@@ -1152,40 +1137,43 @@ typedef struct Tcl_DString {
#define TCL_LINK_SHORT 8
#define TCL_LINK_USHORT 9
#define TCL_LINK_UINT 10
+#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
+#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#else
#define TCL_LINK_LONG 11
#define TCL_LINK_ULONG 12
+#endif
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
+#define TCL_LINK_CHARS 15
+#define TCL_LINK_BINARY 16
#define TCL_LINK_READ_ONLY 0x80
-
+
/*
*----------------------------------------------------------------------------
* Forward declarations of Tcl_HashTable and related types.
*/
+#ifndef TCL_HASH_TYPE
+#if TCL_MAJOR_VERSION > 8
+# define TCL_HASH_TYPE size_t
+#else
+# define TCL_HASH_TYPE unsigned
+#endif
+#endif
+
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
-typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
+typedef TCL_HASH_TYPE (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
- * recalculates it. There should be no reason for turning this flag off as it
- * is completely binary and source compatible unless you directly access the
- * bucketPtr member of the Tcl_HashTableEntry structure. This member has been
- * removed and the space used to store the hash value.
- */
-
-#ifndef TCL_HASH_KEY_STORE_HASH
-# define TCL_HASH_KEY_STORE_HASH 1
-#endif
-
-/*
* Structure definition for an entry in a hash table. No-one outside Tcl
* should access any of these fields directly; use the macros defined below.
*/
@@ -1194,16 +1182,10 @@ struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* 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
* that the offsets of the fields in this
* structure are not changed. */
-#else
- Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first
- * entry in this entry's chain: used for
- * deleting the entry. */
-#endif
- ClientData clientData; /* Application stores something here with
+ void *clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
@@ -1291,11 +1273,11 @@ struct Tcl_HashTable {
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
- int numBuckets; /* Total number of buckets allocated at
+ Tcl_Size numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
- int numEntries; /* Total number of entries present in
+ Tcl_Size numEntries; /* Total number of entries present in
* table. */
- int rebuildSize; /* Enlarge table when numEntries gets to be
+ Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
@@ -1321,7 +1303,7 @@ struct Tcl_HashTable {
typedef struct Tcl_HashSearch {
Tcl_HashTable *tablePtr; /* Table being searched. */
- int nextIndex; /* Index of next bucket to be enumerated after
+ Tcl_Size nextIndex; /* Index of next bucket to be enumerated after
* present one. */
Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current
* bucket. */
@@ -1362,8 +1344,8 @@ typedef struct Tcl_HashSearch {
typedef struct {
void *next; /* Search position for underlying hash
* table. */
- int epoch; /* Epoch marker for dictionary being searched,
- * or -1 if search has terminated. */
+ TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched,
+ * or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
@@ -1395,11 +1377,12 @@ struct Tcl_Event {
};
/*
- * Positions to pass to Tcl_QueueEvent:
+ * Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent:
*/
typedef enum {
- TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
+ TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ TCL_QUEUE_ALERT_IF_EMPTY=4
} Tcl_QueuePosition;
/*
@@ -1428,8 +1411,8 @@ typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr);
* TIP #233 (Virtualized Time)
*/
-typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData);
-typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
+typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, void *clientData);
+typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData);
/*
*----------------------------------------------------------------------------
@@ -1471,10 +1454,12 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
* Channel version tag. This was introduced in 8.3.2/8.4.
*/
+#ifndef TCL_NO_DEPRECATED
#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2)
#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3)
#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4)
+#endif
#define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5)
/*
@@ -1488,41 +1473,41 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
* Typedefs for the various operations in a channel type:
*/
-typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode);
-typedef int (Tcl_DriverCloseProc) (ClientData instanceData,
+typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode);
+typedef int (Tcl_DriverCloseProc) (void *instanceData,
Tcl_Interp *interp);
-typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
+typedef int (Tcl_DriverClose2Proc) (void *instanceData,
Tcl_Interp *interp, int flags);
-typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
+typedef int (Tcl_DriverInputProc) (void *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,
+typedef int (Tcl_DriverOutputProc) (void *instanceData,
+ const char *buf, int toWrite, int *errorCodePtr);
+typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset,
int mode, int *errorCodePtr);
-typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
+typedef int (Tcl_DriverSetOptionProc) (void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
-typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
- Tcl_Interp *interp, CONST84 char *optionName,
+typedef int (Tcl_DriverGetOptionProc) (void *instanceData,
+ Tcl_Interp *interp, const 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,
+typedef void (Tcl_DriverWatchProc) (void *instanceData, int mask);
+typedef int (Tcl_DriverGetHandleProc) (void *instanceData,
+ int direction, void **handlePtr);
+typedef int (Tcl_DriverFlushProc) (void *instanceData);
+typedef int (Tcl_DriverHandlerProc) (void *instanceData,
int interestMask);
-typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
+typedef long long (Tcl_DriverWideSeekProc) (void *instanceData,
+ long long offset, int mode, int *errorCodePtr);
/*
* TIP #218, Channel Thread Actions
*/
-typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData,
+typedef void (Tcl_DriverThreadActionProc) (void *instanceData,
int action);
/*
* TIP #208, File Truncation (etc.)
*/
-typedef int (Tcl_DriverTruncateProc) (ClientData instanceData,
- Tcl_WideInt length);
+typedef int (Tcl_DriverTruncateProc) (void *instanceData,
+ long long length);
/*
* struct Tcl_ChannelType:
@@ -1543,7 +1528,7 @@ typedef struct Tcl_ChannelType {
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
- * TCL_CLOSE2PROC if the close2Proc should be
+ * NULL or TCL_CLOSE2PROC if the close2Proc should be
* used instead. */
Tcl_DriverInputProc *inputProc;
/* Function to call for input on channel. */
@@ -1703,13 +1688,13 @@ typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
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);
+ void **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 void (Tcl_FSFreeInternalRepProc) (void *clientData);
+typedef void *(Tcl_FSDupInternalRepProc) (void *clientData);
+typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData);
+typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr);
typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
@@ -1739,7 +1724,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
typedef struct Tcl_Filesystem {
const char *typeName; /* The name of the filesystem. */
- int structureLength; /* Length of this structure, so future binary
+ Tcl_Size structureLength; /* Length of this structure, so future binary
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
@@ -1901,8 +1886,8 @@ 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. */
- int size; /* Number of bytes in token. */
- int numComponents; /* If this token is composed of other tokens,
+ Tcl_Size size; /* Number of bytes in token. */
+ Tcl_Size numComponents; /* If this token is composed of other tokens,
* this field tells how many of them there are
* (including components of components, etc.).
* The component tokens immediately follow
@@ -2016,25 +2001,25 @@ typedef struct Tcl_Token {
typedef struct Tcl_Parse {
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
+ Tcl_Size 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
* command. */
- int commandSize; /* Number of bytes in command, including first
+ Tcl_Size commandSize; /* Number of bytes in command, including first
* character of first word, up through the
* terminating newline, close bracket, or
* semicolon. */
- int numWords; /* Total number of words in command. May be
+ Tcl_Size numWords; /* Total number of words in command. May be
* 0. */
Tcl_Token *tokenPtr; /* Pointer to first token representing the
* words of the command. Initially points to
* staticTokens, but may change to point to
* malloc-ed space if command exceeds space in
* staticTokens. */
- int numTokens; /* Total number of tokens in command. */
- int tokensAvailable; /* Total number of tokens available at
+ Tcl_Size numTokens; /* Total number of tokens in command. */
+ Tcl_Size tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
@@ -2087,13 +2072,13 @@ typedef struct Tcl_EncodingType {
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
- ClientData clientData; /* Arbitrary value associated with encoding
+ void *clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion functions. */
- int nullSize; /* Number of zero bytes that signify
+ Tcl_Size 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. */
+ * negative. Must be 1, 2, or 4. */
} Tcl_EncodingType;
/*
@@ -2120,10 +2105,10 @@ typedef struct Tcl_EncodingType {
* encountering an invalid byte sequence or a
* source character that has no mapping in the
* target encoding. If clear, the converter
- * substitues the problematic character(s) with
+ * substitutes the problematic character(s) with
* one or more "close" characters in the
* destination buffer and then continues to
- * convert the source.
+ * convert the source. Only for Tcl 8.x.
* TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a
* terminating NUL byte. Since it does not need
* an extra byte for a terminating NUL, it fills
@@ -2138,6 +2123,18 @@ typedef struct Tcl_EncodingType {
* content. Otherwise, the number of chars
* produced is controlled only by other limiting
* factors.
+ * TCL_ENCODING_MODIFIED - Convert NULL bytes to \xC0\x80 in stead of
+ * 0x00. Only valid for "utf-8" and "cesu-8".
+ * This flag is implicit for external -> internal conversions,
+ * optional for internal -> external conversions.
+ * TCL_ENCODING_NOCOMPLAIN - If set, the converter
+ * substitutes the problematic character(s) with
+ * one or more "close" characters in the
+ * destination buffer and then continues to
+ * convert the source. If clear, the converter returns
+ * immediately upon encountering an invalid byte sequence
+ * or a source character that has no mapping in the
+ * target encoding. Only for Tcl 9.x.
*/
#define TCL_ENCODING_START 0x01
@@ -2145,6 +2142,9 @@ typedef struct Tcl_EncodingType {
#define TCL_ENCODING_STOPONERROR 0x04
#define TCL_ENCODING_NO_TERMINATE 0x08
#define TCL_ENCODING_CHAR_LIMIT 0x10
+#define TCL_ENCODING_MODIFIED 0x20
+#define TCL_ENCODING_NOCOMPLAIN 0x40
+#define TCL_ENCODING_STRICT 0x44
/*
* The following definitions are the error codes returned by the conversion
@@ -2181,16 +2181,19 @@ typedef struct Tcl_EncodingType {
/*
* The maximum number of bytes that are necessary to represent a single
- * Unicode character in UTF-8. The valid values should be 3, 4 or 6
- * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or
- * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6,
- * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode
- * is the default and recommended mode. UCS-4 is experimental and not
- * recommended. It works for the core, but most extensions expect UCS-2.
+ * Unicode character in UTF-8. The valid values are 3 and 4
+ * (or perhaps 1 if we want to support a non-unicode enabled core). If 3,
+ * then Tcl_UniChar must be 2-bytes in size (UTF-16) (the default). If > 3,
+ * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UTF-16 mode
+ * is the default and recommended mode.
*/
#ifndef TCL_UTF_MAX
-#define TCL_UTF_MAX 3
+# ifdef BUILD_tcl
+# define TCL_UTF_MAX 4
+# else
+# define TCL_UTF_MAX 3
+# endif
#endif
/*
@@ -2198,15 +2201,13 @@ typedef struct Tcl_EncodingType {
* reflected in regcustom.h.
*/
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
/*
- * unsigned int isn't 100% accurate as it should be a strict 4-byte value.
- * The size of this value must be reflected correctly in regcustom.h.
- * XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode
- * XXX: string rep that Tcl_UniChar represents. Changing the size
- * XXX: of Tcl_UniChar is /not/ supported.
+ * int isn't 100% accurate as it should be a strict 4-byte value
+ * (perhaps int32_t). ILP64/SILP64 systems may have troubles. The
+ * size of this value must be reflected correctly in regcustom.h.
*/
-typedef unsigned int Tcl_UniChar;
+typedef int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
@@ -2238,18 +2239,27 @@ typedef struct Tcl_Config {
* command- or time-limit is exceeded by an interpreter.
*/
-typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp);
-typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData);
+typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp);
+typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData);
+#if 0
/*
*----------------------------------------------------------------------------
- * Override definitions for libtommath.
+ * We would like to provide an anonymous structure "mp_int" here, which is
+ * compatible with libtommath's "mp_int", but without duplicating anything
+ * from <tommath.h> or including <tommath.h> here. But the libtommath project
+ * didn't honor our request. See: <https://github.com/libtom/libtommath/pull/473>
+ *
+ * That's why this part is commented out, and we are using (void *) in
+ * various API's in stead of the more correct (mp_int *).
*/
-typedef struct mp_int mp_int;
+#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
-typedef unsigned int mp_digit;
-#define MP_DIGIT_DECLARED
+typedef struct mp_int mp_int;
+#endif
+
+#endif
/*
*----------------------------------------------------------------------------
@@ -2268,7 +2278,7 @@ typedef struct {
* depends on type.*/
const char *helpStr; /* Documentation message describing this
* option. */
- ClientData clientData; /* Word to pass to function callbacks. */
+ void *clientData; /* Word to pass to function callbacks. */
} Tcl_ArgvInfo;
/*
@@ -2291,9 +2301,9 @@ typedef struct {
* argument types:
*/
-typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr,
+typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr,
void *dstPtr);
-typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv, void *dstPtr);
/*
@@ -2360,10 +2370,25 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
/*
*----------------------------------------------------------------------------
+ * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456]
+ */
+#define TCL_TCPSERVER_REUSEADDR (1<<0)
+#define TCL_TCPSERVER_REUSEPORT (1<<1)
+
+/*
+ * Constants for special Tcl_Size-typed values, see TIP #494
+ */
+
+#define TCL_IO_FAILURE ((Tcl_Size)-1)
+#define TCL_AUTO_LENGTH ((Tcl_Size)-1)
+#define TCL_INDEX_NONE ((Tcl_Size)-1)
+
+/*
+ *----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
-typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
+typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp,
int result);
/*
@@ -2382,17 +2407,24 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
*/
const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
- int exact);
+ int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
+#if defined(_WIN32)
+ TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
+#else
+# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
+#endif
-/*
- * When not using stubs, make it a macro.
- */
-
-#ifndef USE_TCL_STUBS
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, exact)
+#ifdef USE_TCL_STUBS
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+#else
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#endif
/*
@@ -2401,12 +2433,22 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- ((Tcl_CreateInterp)()))
-EXTERN void Tcl_MainEx(int argc, char **argv,
+ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)()))
+EXTERN void Tcl_MainEx(Tcl_Size argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
+EXTERN const char * Tcl_InitSubsystems(void);
EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
+EXTERN const char * Tcl_SetPreInitScript(const char *string);
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_StaticPackage Tcl_StaticLibrary
+#endif
+#ifdef _WIN32
+EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv);
+#else
+EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
+#endif
/*
*----------------------------------------------------------------------------
@@ -2477,19 +2519,24 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#endif /* !TCL_MEM_DEBUG */
#ifdef TCL_MEM_DEBUG
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#else
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* https://wiki.c2.com/?TrivialDoWhileLoop
*/
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
@@ -2497,6 +2544,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
TclFreeObj(_objPtr); \
} \
} while(0)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
@@ -2513,22 +2561,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
Tcl_DbNewBignumObj(val, __FILE__, __LINE__)
# undef Tcl_NewBooleanObj
# define Tcl_NewBooleanObj(val) \
- Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
+ Tcl_DbNewWideIntObj((val)!=0, __FILE__, __LINE__)
# undef Tcl_NewByteArrayObj
# define Tcl_NewByteArrayObj(bytes, len) \
Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
# undef Tcl_NewDoubleObj
# define Tcl_NewDoubleObj(val) \
Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
-# undef Tcl_NewIntObj
-# define Tcl_NewIntObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewListObj
# define Tcl_NewListObj(objc, objv) \
Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
-# undef Tcl_NewLongObj
-# define Tcl_NewLongObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewObj
# define Tcl_NewObj() \
Tcl_DbNewObj(__FILE__, __LINE__)
@@ -2546,7 +2588,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
*/
#define Tcl_GetHashValue(h) ((h)->clientData)
-#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
+#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *)(value))
#define Tcl_GetHashKey(tablePtr, h) \
((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
(tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
@@ -2567,31 +2609,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
/*
*----------------------------------------------------------------------------
- * Macros that eliminate the overhead of the thread synchronization functions
- * when compiling without thread support.
- */
-
-#ifndef TCL_THREADS
-#undef Tcl_MutexLock
-#define Tcl_MutexLock(mutexPtr)
-#undef Tcl_MutexUnlock
-#define Tcl_MutexUnlock(mutexPtr)
-#undef Tcl_MutexFinalize
-#define Tcl_MutexFinalize(mutexPtr)
-#undef Tcl_ConditionNotify
-#define Tcl_ConditionNotify(condPtr)
-#undef Tcl_ConditionWait
-#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
-#undef Tcl_ConditionFinalize
-#define Tcl_ConditionFinalize(condPtr)
-#endif /* TCL_THREADS */
-
-/*
- *----------------------------------------------------------------------------
* Deprecated Tcl functions:
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibility.
@@ -2606,7 +2627,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define panic Tcl_Panic
#endif
# define panicVA Tcl_PanicVA
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------------
@@ -2617,6 +2637,8 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
extern Tcl_AppInitProc Tcl_AppInit;
+#endif /* !TCL_NO_DEPRECATED */
+
#endif /* RC_INVOKED */
/*
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index cc683b6..03655b9 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -6,9 +6,9 @@
* that don't exactly fit are passed up to the next larger size. Blocks
* over a certain size are directly allocated from the system.
*
- * Copyright (c) 1983 Regents of the University of California.
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1983 Regents of the University of California.
+ * Copyright © 1996-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
*
@@ -22,7 +22,7 @@
*/
#include "tclInt.h"
-#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
+#if !TCL_THREADS || !defined(USE_THREAD_ALLOC)
#if defined(USE_TCLALLOC) && USE_TCLALLOC
@@ -31,8 +31,8 @@
* until Tcl uses config.h properly.
*/
-#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
+#if defined(_MSC_VER) || defined(__MSVCRT__)
+typedef size_t caddr_t;
#endif
/*
@@ -56,7 +56,7 @@ union overhead {
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
- unsigned long size; /* actual block size */
+ size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
@@ -94,7 +94,7 @@ union overhead {
#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1))
#define NBUCKETS (13 - (MINBLOCK >> 4))
-#define MAXMALLOC (1<<(NBUCKETS+2))
+#define MAXMALLOC ((size_t)1 << (NBUCKETS+2))
static union overhead *nextf[NBUCKETS];
/*
@@ -121,7 +121,7 @@ static struct block bigBlocks={ /* Big blocks aren't suballocated. */
* variable.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;
@@ -133,7 +133,7 @@ static int allocInit = 0;
* a given block size.
*/
-static unsigned int numMallocs[NBUCKETS+1];
+static size_t numMallocs[NBUCKETS+1];
#endif
#if !defined(NDEBUG)
@@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
-static void MoreCore(int bucket);
+static void MoreCore(size_t bucket);
/*
*-------------------------------------------------------------------------
@@ -171,7 +171,7 @@ TclInitAlloc(void)
{
if (!allocInit) {
allocInit = 1;
-#ifdef TCL_THREADS
+#if TCL_THREADS
allocMutexPtr = Tcl_GetAllocMutex();
#endif
}
@@ -249,12 +249,12 @@ TclFinalizeAllocSubsystem(void)
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
union overhead *overPtr;
- long bucket;
+ size_t bucket;
unsigned amount;
struct block *bigBlockPtr = NULL;
@@ -275,7 +275,7 @@ TclpAlloc(
if (numBytes >= MAXMALLOC - OVERHEAD) {
if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
bigBlockPtr = (struct block *) TclpSysAlloc(
- (sizeof(struct block) + OVERHEAD + numBytes), 0);
+ sizeof(struct block) + OVERHEAD + numBytes, 0);
}
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
@@ -304,7 +304,7 @@ TclpAlloc(
#endif
Tcl_MutexUnlock(allocMutexPtr);
- return (void *)(overPtr+1);
+ return (char *)(overPtr+1);
}
/*
@@ -385,12 +385,12 @@ TclpAlloc(
static void
MoreCore(
- int bucket) /* What bucket to allocat to. */
+ size_t bucket) /* What bucket to allocate to. */
{
union overhead *overPtr;
- long size; /* size of desired block */
- long amount; /* amount to allocate */
- int numBlocks; /* how many blocks we get */
+ size_t size; /* size of desired block */
+ size_t amount; /* amount to allocate */
+ size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
@@ -398,7 +398,7 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
- size = 1 << (bucket + 3);
+ size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
@@ -446,9 +446,9 @@ MoreCore(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
- long size;
+ size_t size;
union overhead *overPtr;
struct block *bigBlockPtr;
@@ -509,16 +509,16 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloced block. */
+ void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
- unsigned long maxSize;
+ size_t maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
@@ -581,9 +581,9 @@ TclpRealloc(
#endif
Tcl_MutexUnlock(allocMutexPtr);
- return (char *)(overPtr+1);
+ return (void *)(overPtr+1);
}
- maxSize = 1 << (i+3);
+ maxSize = (size_t)1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
@@ -645,29 +645,29 @@ void
mstats(
char *s) /* Where to write info. */
{
- int i, j;
+ unsigned int i, j;
union overhead *overPtr;
- int totalFree = 0, totalUsed = 0;
+ size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
- fprintf(stderr, " %d", j);
+ fprintf(stderr, " %u", j);
}
- totalFree += j * (1 << (i + 3));
+ totalFree += ((size_t)j) * ((size_t)1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %d", numMallocs[i]);
- totalUsed += numMallocs[i] * (1 << (i + 3));
+ fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]);
+ totalUsed += numMallocs[i] * ((size_t)1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
- totalUsed, totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n",
+ totalUsed, totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%" TCL_Z_MODIFIER "u) blocks in use: %" TCL_Z_MODIFIER "u\n",
MAXMALLOC, numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
@@ -692,11 +692,11 @@ mstats(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
- return (char *) malloc(numBytes);
+ return malloc(numBytes);
}
/*
@@ -717,7 +717,7 @@ TclpAlloc(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
@@ -739,15 +739,17 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloced block. */
+ void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
- return (char *) realloc(oldPtr, numBytes);
+ return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
+#else
+TCL_MAC_EMPTY_FILE(generic_tclAlloc_c)
#endif /* !TCL_THREADS */
/*
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100755
index 0000000..0419841
--- /dev/null
+++ b/generic/tclArithSeries.c
@@ -0,0 +1,1004 @@
+/*
+ * tclArithSeries.c --
+ *
+ * This file contains the ArithSeries concrete abstract list
+ * implementation. It implements the inner workings of the lseq command.
+ *
+ * Copyright © 2022 Brian S. Griffin.
+ *
+ * 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 "tclArithSeries.h"
+#include <assert.h>
+
+/* -------------------------- ArithSeries object ---------------------------- */
+
+
+#define ArithSeriesRepPtr(arithSeriesObjPtr) \
+ (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1)
+
+#define ArithSeriesIndexM(arithSeriesRepPtr, index) \
+ ((arithSeriesRepPtr)->isDouble ? \
+ (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \
+ : \
+ ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step)))
+
+#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \
+ (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr);
+static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfArithSeries (Tcl_Obj *arithSeriesObj);
+static Tcl_Obj *ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr);
+
+/*
+ * The structure below defines the arithmetic series Tcl object type by
+ * means of procedures that can be invoked by generic object code.
+ *
+ * The arithmetic series object is a special case of Tcl list representing
+ * an interval of an arithmetic series in constant space.
+ *
+ * The arithmetic series is internally represented with three integers,
+ * *start*, *end*, and *step*, Where the length is calculated with
+ * the following algorithm:
+ *
+ * if RANGE == 0 THEN
+ * ERROR
+ * if RANGE > 0
+ * LEN is (((END-START)-1)/STEP) + 1
+ * else if RANGE < 0
+ * LEN is (((END-START)-1)/STEP) - 1
+ *
+ * And where the equivalent's list I-th element is calculated
+ * as:
+ *
+ * LIST[i] = START + (STEP * i)
+ *
+ * Zero elements ranges, like in the case of START=10 END=10 STEP=1
+ * are valid and will be equivalent to the empty list.
+ */
+
+const Tcl_ObjType tclArithSeriesType = {
+ "arithseries", /* name */
+ FreeArithSeriesInternalRep, /* freeIntRepProc */
+ DupArithSeriesInternalRep, /* dupIntRepProc */
+ UpdateStringOfArithSeries, /* updateStringProc */
+ SetArithSeriesFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesLen --
+ *
+ * Compute the length of the equivalent list where
+ * every element is generated starting from *start*,
+ * and adding *step* to generate every successive element
+ * that's < *end* for positive steps, or > *end* for negative
+ * steps.
+ *
+ * Results:
+ *
+ * The length of the list generated by the given range,
+ * that may be zero.
+ * The function returns -1 if the list is of length infinite.
+ *
+ * Side effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_WideInt
+ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
+{
+ Tcl_WideInt len;
+
+ if (step == 0) {
+ return 0;
+ }
+ len = 1 + ((end-start)/step);
+ return (len < 0) ? -1 : len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewArithSeriesInt --
+ *
+ * Creates a new ArithSeries object. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static
+Tcl_Obj *
+NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len)
+{
+ Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesObj;
+ ArithSeries *arithSeriesRepPtr;
+
+ TclNewObj(arithSeriesObj);
+
+ if (length <= 0) {
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries));
+ arithSeriesRepPtr->isDouble = 0;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesObj->typePtr = &tclArithSeriesType;
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewArithSeriesDbl --
+ *
+ * Creates a new ArithSeries object with doubles. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static
+Tcl_Obj *
+NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len)
+{
+ Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesObj;
+ ArithSeriesDbl *arithSeriesRepPtr;
+
+ TclNewObj(arithSeriesObj);
+
+ if (length <= 0) {
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl));
+ arithSeriesRepPtr->isDouble = 1;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesObj->typePtr = &tclArithSeriesType;
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * assignNumber --
+ *
+ * Create the appropriate Tcl_Obj value for the given numeric values.
+ * Used locally only for decoding [lseq] numeric arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer.
+ * No assignment on error.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static void
+assignNumber(
+ int useDoubles,
+ Tcl_WideInt *intNumberPtr,
+ double *dblNumberPtr,
+ Tcl_Obj *numberObj)
+{
+ void *clientData;
+ int tcl_number_type;
+
+ if (Tcl_GetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK
+ || tcl_number_type == TCL_NUMBER_BIG) {
+ return;
+ }
+ if (useDoubles) {
+ if (tcl_number_type != TCL_NUMBER_INT) {
+ *dblNumberPtr = *(double *)clientData;
+ } else {
+ *dblNumberPtr = (double)*(Tcl_WideInt *)clientData;
+ }
+ } else {
+ if (tcl_number_type == TCL_NUMBER_INT) {
+ *intNumberPtr = *(Tcl_WideInt *)clientData;
+ } else {
+ *intNumberPtr = (Tcl_WideInt)*(double *)clientData;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewArithSeriesObj --
+ *
+ * Creates a new ArithSeries object. Some arguments may be NULL and will
+ * be computed based on the other given arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * An empty Tcl_Obj if the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNewArithSeriesObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj **arithSeriesObj, /* return value */
+ int useDoubles, /* Flag indicates values start,
+ ** end, step, are treated as doubles */
+ Tcl_Obj *startObj, /* Starting value */
+ Tcl_Obj *endObj, /* Ending limit */
+ Tcl_Obj *stepObj, /* increment value */
+ Tcl_Obj *lenObj) /* Number of elements */
+{
+ double dstart, dend, dstep;
+ Tcl_WideInt start, end, step, len;
+
+ if (startObj) {
+ assignNumber(useDoubles, &start, &dstart, startObj);
+ } else {
+ start = 0;
+ dstart = start;
+ }
+ if (stepObj) {
+ assignNumber(useDoubles, &step, &dstep, stepObj);
+ if (useDoubles) {
+ step = dstep;
+ } else {
+ dstep = step;
+ }
+ if (dstep == 0) {
+ *arithSeriesObj = Tcl_NewObj();
+ return TCL_OK;
+ }
+ }
+ if (endObj) {
+ assignNumber(useDoubles, &end, &dend, endObj);
+ }
+ if (lenObj) {
+ if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (startObj && endObj) {
+ if (!stepObj) {
+ if (useDoubles) {
+ dstep = (dstart < dend) ? 1.0 : -1.0;
+ step = dstep;
+ } else {
+ step = (start < end) ? 1 : -1;
+ dstep = step;
+ }
+ }
+ assert(dstep!=0);
+ if (!lenObj) {
+ if (useDoubles) {
+ len = (dend - dstart + dstep)/dstep;
+ } else {
+ len = (end - start + step)/step;
+ }
+ }
+ }
+
+ if (!endObj) {
+ if (useDoubles) {
+ dend = dstart + (dstep * (len-1));
+ end = dend;
+ } else {
+ end = start + (step * (len-1));
+ dend = end;
+ }
+ }
+
+ if (TCL_MAJOR_VERSION < 9 && len > ListSizeT_MAX) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ return TCL_ERROR;
+ }
+
+ if (arithSeriesObj) {
+ *arithSeriesObj = (useDoubles)
+ ? NewArithSeriesDbl(dstart, dend, dstep, len)
+ : NewArithSeriesInt(start, end, step, len);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesObjStep --
+ *
+ * Return a Tcl_Obj with the step value from the give ArithSeries Obj.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+ArithSeriesObjStep(
+ Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *stepObj;
+
+ if (arithSeriesObj->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj);
+ if (arithSeriesRepPtr->isDouble) {
+ TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
+ } else {
+ TclNewIntObj(stepObj, arithSeriesRepPtr->step);
+ }
+ return stepObj;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjIndex --
+ *
+ * Returns the element with the specified index in the list
+ * represented by the specified Arithmetic Sequence object.
+ * If the index is out of range, NULL is returned.
+ *
+ * Results:
+ *
+ * The element on success, NULL on index out of range.
+ *
+ * Side Effects:
+ *
+ * On success, the integer pointed by *element is modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjIndex(
+ Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesObj,
+ Tcl_Size index)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesObj->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj);
+ if (index < 0 || index >= arithSeriesRepPtr->len) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("index %d is out of bounds 0 to %"
+ "d", index, (arithSeriesRepPtr->len-1)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ } else {
+ return Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjLength
+ *
+ * Returns the length of the arithmetic series.
+ *
+ * Results:
+ *
+ * The length of the series as Tcl_WideInt.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)
+ arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ return arithSeriesRepPtr->len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesInternalRep --
+ *
+ * Deallocate the storage associated with an arithseries object's
+ * internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees arithSeriesObj's ArithSeries* internal representation and
+ * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ Tcl_Obj**elmts = arithSeriesRepPtr->elements;
+ for(i=0; i<arithSeriesRepPtr->len; i++) {
+ if (elmts[i]) {
+ Tcl_DecrRefCount(elmts[i]);
+ }
+ }
+ ckfree((char *) arithSeriesRepPtr->elements);
+ }
+ ckfree((char *) arithSeriesRepPtr);
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupArithSeriesInternalRep --
+ *
+ * Initialize the internal representation of a arithseries Tcl_Obj to a
+ * copy of the internal representation of an existing arithseries object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * We set "copyPtr"s internal rep to a pointer to a
+ * newly allocated ArithSeries structure.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupArithSeriesInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ ArithSeries *srcArithSeriesRepPtr =
+ (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1;
+ ArithSeries *copyArithSeriesRepPtr;
+
+ /*
+ * Allocate a new ArithSeries structure. */
+
+ copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries));
+ *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
+ copyArithSeriesRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &tclArithSeriesType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfArithSeries --
+ *
+ * Update the string representation for an arithseries object.
+ * Note: This procedure does not invalidate an existing old string rep
+ * so storage will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to a valid string that results from
+ * the list-to-string conversion. This string will be empty if the
+ * list has no elements. The list internal representation
+ * should not be NULL and we assume it is not NULL.
+ *
+ * Notes:
+ * At the cost of overallocation it's possible to estimate
+ * the length of the string representation and make this procedure
+ * much faster. Because the programmer shouldn't expect the
+ * string conversion of a big arithmetic sequence to be fast
+ * this version takes more care of space than time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ char *elem, *p;
+ Tcl_Obj *elemObj;
+ Tcl_WideInt i;
+ Tcl_WideInt length = 0;
+ int slen;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ Tcl_DecrRefCount(elemObj);
+ slen += 1; /* + 1 is for the space or the nul-term */
+ length += slen;
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObj, NULL, length);
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ strcpy(p, elem);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (length > 0) arithSeriesObj->bytes[length-1] = '\0';
+ arithSeriesObj->length = length-1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetArithSeriesFromAny --
+ *
+ * The Arithmetic Series object is just an way to optimize
+ * Lists space complexity, so no one should try to convert
+ * a string to an Arithmetic Series object.
+ *
+ * This function is here just to populate the Type structure.
+ *
+ * Results:
+ *
+ * The result is always TCL_ERROR. But see Side Effects.
+ *
+ * Side effects:
+ *
+ * Tcl Panic if called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArithSeriesFromAny(
+ TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */
+{
+ Tcl_Panic("SetArithSeriesFromAny: should never be called");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjCopy --
+ *
+ * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C
+ * level a counterpart of the [lrange $list 0 end] command, while using
+ * internals details to be as efficient as possible.
+ *
+ * Results:
+ *
+ * Normally returns a pointer to a new Tcl_Obj, that contains the same
+ * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a
+ * refCount of zero. If *arithSeriesObj does not hold an arithSeries,
+ * NULL is returned, and if interp is non-NULL, an error message is
+ * recorded there.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjCopy(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *arithSeriesObj) /* List object for which an element array is
+ * to be returned. */
+{
+ Tcl_Obj *copyPtr;
+ ArithSeries *arithSeriesRepPtr;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+ if (NULL == arithSeriesRepPtr) {
+ if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) {
+ /* We know this is going to panic, but it's the message we want */
+ return NULL;
+ }
+ }
+
+ TclNewObj(copyPtr);
+ TclInvalidateStringRep(copyPtr);
+ DupArithSeriesInternalRep(arithSeriesObj, copyPtr);
+ return copyPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjRange --
+ *
+ * Makes a slice of an ArithSeries value.
+ * *arithSeriesObj must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the sliced series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjRange(
+ Tcl_Interp *interp, /* For error message(s) */
+ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
+ Tcl_Size fromIdx, /* Index of first element to include. */
+ Tcl_Size toIdx) /* Index of last element to include. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (fromIdx > toIdx) {
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+
+ startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx);
+ if (startObj == NULL) {
+ return NULL;
+ }
+ Tcl_IncrRefCount(startObj);
+ endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx);
+ if (endObj == NULL) {
+ return NULL;
+ }
+ Tcl_IncrRefCount(endObj);
+ stepObj = ArithSeriesObjStep(arithSeriesObj);
+ Tcl_IncrRefCount(stepObj);
+
+ if (Tcl_IsShared(arithSeriesObj) ||
+ ((arithSeriesObj->refCount > 1))) {
+ Tcl_Obj *newSlicePtr;
+ if (TclNewArithSeriesObj(interp, &newSlicePtr,
+ arithSeriesRepPtr->isDouble, startObj, endObj,
+ stepObj, NULL) != TCL_OK) {
+ newSlicePtr = NULL;
+ }
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+ return newSlicePtr;
+ }
+
+ /*
+ * In-place is possible.
+ */
+
+ /*
+ * Even if nothing below causes any changes, we still want the
+ * string-canonizing effect of [lrange 0 end].
+ */
+
+ TclInvalidateStringRep(arithSeriesObj);
+
+ if (arithSeriesRepPtr->isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesObj;
+ double start, end, step;
+ Tcl_GetDoubleFromObj(NULL, startObj, &start);
+ Tcl_GetDoubleFromObj(NULL, endObj, &end);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &step);
+ arithSeriesDblRepPtr->start = start;
+ arithSeriesDblRepPtr->end = end;
+ arithSeriesDblRepPtr->step = step;
+ arithSeriesDblRepPtr->len = (end-start+step)/step;
+ arithSeriesDblRepPtr->elements = NULL;
+
+ } else {
+ Tcl_WideInt start, end, step;
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = (end-start+step)/step;
+ arithSeriesRepPtr->elements = NULL;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesGetElements --
+ *
+ * This function returns an (objc,objv) array of the elements in a list
+ * object.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case *objcPtr is set to
+ * the count of list elements and *objvPtr is set to a pointer to an
+ * array of (*objcPtr) pointers to each list element. If listPtr does not
+ * refer to an Abstract List object and the object can not be converted
+ * to one, TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * The objects referenced by the returned array should be treated as
+ * readonly and their ref counts are _not_ incremented; the caller must
+ * do that if it holds on to a reference. Furthermore, the pointer and
+ * length returned by this function may change as soon as any function is
+ * called on the list object; be careful about retaining the pointer in a
+ * local data structure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclArithSeriesGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *objPtr, /* ArithSeries object for which an element
+ * array is to be returned. */
+ Tcl_Size *objcPtr, /* Where to store the count of objects
+ * referenced by objv. */
+ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
+ * pointers to the list's objects. */
+{
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj **objv;
+ int i, objc;
+
+ ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr);
+ objc = arithSeriesRepPtr->len;
+ if (objc > 0) {
+ if (arithSeriesRepPtr->elements) {
+ /* If this exists, it has already been populated */
+ objv = arithSeriesRepPtr->elements;
+ } else {
+ /* Construct the elements array */
+ objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc);
+ if (objv == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ arithSeriesRepPtr->elements = objv;
+ for (i = 0; i < objc; i++) {
+ objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);
+ if (objv[i] == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(objv[i]);
+ }
+ }
+ } else {
+ objv = NULL;
+ }
+ *objvPtr = objv;
+ *objcPtr = objc;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an arithseries"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjReverse --
+ *
+ * Reverse the order of the ArithSeries value.
+ * *arithSeriesObj must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the reordered series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjReverse(
+ Tcl_Interp *interp, /* For error message(s) */
+ Tcl_Obj *arithSeriesObj) /* List object to reverse. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+ Tcl_Obj *resultObj;
+ Tcl_WideInt start, end, step, len;
+ double dstart, dend, dstep;
+ int isDouble;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+
+ isDouble = arithSeriesRepPtr->isDouble;
+ len = arithSeriesRepPtr->len;
+
+ startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1));
+ Tcl_IncrRefCount(startObj);
+ endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0);
+ Tcl_IncrRefCount(endObj);
+ stepObj = ArithSeriesObjStep(arithSeriesObj);
+ Tcl_IncrRefCount(stepObj);
+
+ if (isDouble) {
+ Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
+ Tcl_GetDoubleFromObj(NULL, endObj, &dend);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &dstep);
+ dstep = -dstep;
+ TclSetDoubleObj(stepObj, dstep);
+ } else {
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ step = -step;
+ TclSetIntObj(stepObj, step);
+ }
+
+ if (Tcl_IsShared(arithSeriesObj) ||
+ ((arithSeriesObj->refCount > 1))) {
+ Tcl_Obj *lenObj;
+ TclNewIntObj(lenObj, len);
+ if (TclNewArithSeriesObj(interp, &resultObj,
+ isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) {
+ resultObj = NULL;
+ }
+ Tcl_DecrRefCount(lenObj);
+ } else {
+
+ /*
+ * In-place is possible.
+ */
+
+ TclInvalidateStringRep(arithSeriesObj);
+
+ if (isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr =
+ (ArithSeriesDbl*)arithSeriesRepPtr;
+ arithSeriesDblRepPtr->start = dstart;
+ arithSeriesDblRepPtr->end = dend;
+ arithSeriesDblRepPtr->step = dstep;
+ } else {
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ }
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ for (i=0; i<len; i++) {
+ Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
+ }
+ ckfree((char*)arithSeriesRepPtr->elements);
+ }
+ arithSeriesRepPtr->elements = NULL;
+
+ resultObj = arithSeriesObj;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return resultObj;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
new file mode 100644
index 0000000..947d437
--- /dev/null
+++ b/generic/tclArithSeries.h
@@ -0,0 +1,58 @@
+/*
+ * tclArithSeries.h --
+ *
+ * This file contains the ArithSeries concrete abstract list
+ * implementation. It implements the inner workings of the lseq command.
+ *
+ * Copyright © 2022 Brian S. Griffin.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+/*
+ * The structure used for the ArithSeries internal representation.
+ * Note that the len can in theory be always computed by start,end,step
+ * but it's faster to cache it inside the internal representation.
+ */
+typedef struct {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ Tcl_WideInt start;
+ Tcl_WideInt end;
+ Tcl_WideInt step;
+} ArithSeries;
+typedef struct {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ double start;
+ double end;
+ double step;
+} ArithSeriesDbl;
+
+
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *,
+ Tcl_Size index);
+MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr);
+MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp,
+ Tcl_Obj **arithSeriesObj, int useDoubles,
+ Tcl_Obj *startObj, Tcl_Obj *endObj,
+ Tcl_Obj *stepObj, Tcl_Obj *lenObj);
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index e69348c..ab5cd7a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -6,8 +6,8 @@
* 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.
+ * Copyright © 2010 Ozgur Dogan Ugurlu.
+ * Copyright © 2010 Kevin B. Kenny.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -32,6 +32,7 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure that represents a range of instructions in the bytecode.
@@ -130,7 +131,7 @@ enum BasicBlockFlags {
* Source instruction type recognized by the assembler.
*/
-typedef enum TalInstType {
+typedef enum {
ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be
* converted to appropriate exception
@@ -186,8 +187,10 @@ typedef enum TalInstType {
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
- ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by
+ ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
* LVT entry. Fixed arity */
+ ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2
+ * operands, produces 1, N > 0 */
} TalInstType;
/*
@@ -271,15 +274,12 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
const 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*);
@@ -317,6 +317,9 @@ static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
* Tcl_ObjType that describes bytecode emitted by the assembler.
*/
+static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep;
+static Tcl_DupInternalRepProc DupAssembleCodeInternalRep;
+
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
@@ -360,6 +363,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
+ {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
@@ -469,8 +473,12 @@ static const TalInstDesc TalInstructionTable[] = {
{"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
+ {"strge", ASSEM_1BYTE, INST_STR_GE, 2, 1},
+ {"strgt", ASSEM_1BYTE, INST_STR_GT, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
+ {"strle", ASSEM_1BYTE, INST_STR_LE, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
+ {"strlt", ASSEM_1BYTE, INST_STR_LT, 2, 1},
{"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
@@ -527,7 +535,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
- INST_NUM_TYPE /* 180 */
+ INST_NUM_TYPE, /* 180 */
+ INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */
};
/*
@@ -618,10 +627,14 @@ BBUpdateStackReqs(
if (consumed == INT_MIN) {
/*
- * The instruction is variadic; it consumes 'count' operands.
+ * The instruction is variadic; it consumes 'count' operands, or
+ * 'count+1' for ASSEM_DICT_GET_DEF.
*/
consumed = count;
+ if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) {
+ consumed++;
+ }
}
if (produced < 0) {
/*
@@ -759,7 +772,7 @@ BBEmitInst1or4(
int
Tcl_AssembleObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData, /* clientData */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -769,12 +782,12 @@ Tcl_AssembleObjCmd(
* because there needs to be one in place to execute bytecode.
*/
- return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv);
}
int
TclNRAssembleObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -783,7 +796,6 @@ TclNRAssembleObjCmd(
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
@@ -853,9 +865,10 @@ CompileAssembleObj(
* is valid in the current context.
*/
- if (objPtr->typePtr == &assembleCodeType) {
+ ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr);
+
+ if (codePtr) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -869,7 +882,7 @@ CompileAssembleObj(
* Not valid, so free it and regenerate.
*/
- FreeAssembleCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
@@ -894,15 +907,13 @@ CompileAssembleObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &assembleCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
/*
* Record the local variable context to which the bytecode pertains
*/
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -949,8 +960,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
@@ -958,7 +968,6 @@ TclCompileAssembleCmd(
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
- (void)cmdPtr;
/*
* Make sure that the command has a single arg that is a simple word.
*/
@@ -1081,8 +1090,8 @@ TclAssembleCode(
#ifdef TCL_COMPILE_DEBUG
if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
- printf(" %4ld Assembling: ",
- (long)(envPtr->codeNext - envPtr->codeStart));
+ printf(" %4" TCL_Z_MODIFIER "d Assembling: ",
+ (size_t)(envPtr->codeNext - envPtr->codeStart));
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(instLen, 55));
printf("\n");
@@ -1257,7 +1266,7 @@ AssembleOneLine(
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
- enum TalInstType instType; /* Type of the instruction */
+ TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
@@ -1304,8 +1313,8 @@ AssembleOneLine(
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
- operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
@@ -1397,6 +1406,7 @@ AssembleOneLine(
break;
case ASSEM_DICT_GET:
+ case ASSEM_DICT_GET_DEF:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
@@ -1470,8 +1480,8 @@ AssembleOneLine(
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
- operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
@@ -1565,7 +1575,7 @@ AssembleOneLine(
* Add the (label_name, address) pair to the hash table.
*/
- if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
@@ -1742,7 +1752,7 @@ AssembleOneLine(
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
- Tcl_GetString(instNameObj));
+ TclGetString(instNameObj));
}
status = TCL_OK;
@@ -1975,7 +1985,7 @@ CreateMirrorJumpTable(
* table. */
int i;
- if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
+ if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) {
return TCL_ERROR;
}
if (objc % 2 != 0) {
@@ -1987,6 +1997,9 @@ CreateMirrorJumpTable(
}
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Allocate the jumptable.
@@ -2002,15 +2015,15 @@ CreateMirrorJumpTable(
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]),
+ DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]),
+ TclGetString(objv[i+1]));
+ hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
- Tcl_GetString(objv[i])));
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
@@ -2259,7 +2272,7 @@ GetListIndexOperand(
* when list size limits grow.
*/
status = TclIndexEncode(interp, value,
- TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);
+ TCL_INDEX_NONE,TCL_INDEX_NONE, result);
Tcl_DecrRefCount(value);
*tokenPtrPtr = TokenAfter(tokenPtr);
@@ -2307,7 +2320,7 @@ FindLocalVar(
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return -1;
}
- varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
+ varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return -1;
@@ -2820,7 +2833,7 @@ CalculateJumpRelocations(
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
@@ -2901,10 +2914,10 @@ CheckJumpTableLabels(
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), (valEntryPtr != NULL));
+ TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
@@ -2942,9 +2955,9 @@ ReportUndefinedLabel(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "undefined label \"%s\"", Tcl_GetString(jumpTarget)));
+ "undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
- Tcl_GetString(jumpTarget), NULL);
+ TclGetString(jumpTarget), NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
@@ -3027,7 +3040,7 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
@@ -3099,17 +3112,17 @@ ResolveJumpTableTargets(
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
- DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+ DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*)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,
+ TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
@@ -3481,7 +3494,7 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(blockPtr->jumpTarget));
+ TclGetString(blockPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
@@ -3498,7 +3511,7 @@ StackCheckBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
@@ -3560,7 +3573,7 @@ StackCheckExit(
* Emit a 'push' of the empty literal.
*/
- litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+ litIndex = TclRegisterLiteral(envPtr, "", 0, 0);
/*
* Assumes that 'push' is at slot 0 in TalInstructionTable.
@@ -3803,7 +3816,7 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3819,7 +3832,7 @@ ProcessCatchesInBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -4123,7 +4136,7 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(block->jumpTarget));
+ TclGetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
@@ -4265,7 +4278,7 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
- Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
+ TclSetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
@@ -4302,12 +4315,9 @@ AddBasicBlockRangeToErrorInfo(
static void
DupAssembleCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
- (void)srcPtr;
- (void)copyPtr;
-
return;
}
@@ -4333,12 +4343,12 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
- objPtr->typePtr = NULL;
+ ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
/*
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index d1871f9..9ce2c88 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -5,8 +5,8 @@
* in a safe way. The code here doesn't actually handle signals, though.
* This code is based on proposals made by Mark Diekhans and Don Libes.
*
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
+ * Copyright © 1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -25,9 +25,9 @@ typedef struct AsyncHandler {
int ready; /* Non-zero means this handler should be
* invoked in the next call to
* Tcl_AsyncInvoke. */
- struct AsyncHandler *nextPtr;
- /* Next in list of all handlers for the
- * process. */
+ struct AsyncHandler *nextPtr, *prevPtr;
+ /* Next, previous in list of all handlers
+ * for the process. */
Tcl_AsyncProc *proc; /* Procedure to call when handler is
* invoked. */
ClientData clientData; /* Value to pass to handler when it is
@@ -38,16 +38,10 @@ typedef struct AsyncHandler {
* associated to. */
Tcl_ThreadId originThrdId; /* Origin thread where this token was created
* and where it will be yielded. */
+ ClientData notifierData; /* Platform notifier data or NULL. */
} AsyncHandler;
typedef struct ThreadSpecificData {
- /*
- * The variables below maintain a list of all existing handlers specific
- * to the calling thread.
- */
- AsyncHandler *firstHandler; /* First handler defined for process, or NULL
- * if none. */
- AsyncHandler *lastHandler; /* Last handler or NULL. */
int asyncReady; /* This is set to 1 whenever a handler becomes
* ready and it is cleared to zero whenever
* Tcl_AsyncInvoke is called. It can be
@@ -58,24 +52,29 @@ typedef struct ThreadSpecificData {
* currently working. If so then we won't set
* asyncReady again until Tcl_AsyncInvoke
* returns. */
- Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list
- * lock */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+
+/* Mutex to protect linked-list of AsyncHandlers in the process. */
+TCL_DECLARE_MUTEX(asyncMutex)
+
+/* List of all existing handlers of the process. */
+static AsyncHandler *firstHandler = NULL;
+static AsyncHandler *lastHandler = NULL;
/*
*----------------------------------------------------------------------
*
* TclFinalizeAsync --
*
- * Finalizes the mutex in the thread local data structure for the async
+ * Finalizes the thread local data structure for the async
* subsystem.
*
* Results:
* None.
*
* Side effects:
- * Forgets knowledge of the mutex should it have been created.
+ * Cleans up left-over async handlers for the calling thread.
*
*----------------------------------------------------------------------
*/
@@ -83,10 +82,40 @@ static Tcl_ThreadDataKey dataKey;
void
TclFinalizeAsync(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ AsyncHandler *token, *toDelete = NULL;
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
+
+ Tcl_MutexLock(&asyncMutex);
+ for (token = firstHandler; token != NULL;) {
+ AsyncHandler *nextToken = token->nextPtr;
- if (tsdPtr->asyncMutex != NULL) {
- Tcl_MutexFinalize(&tsdPtr->asyncMutex);
+ if (token->originThrdId == self) {
+ if (token->prevPtr == NULL) {
+ firstHandler = token->nextPtr;
+ if (firstHandler == NULL) {
+ lastHandler = NULL;
+ break;
+ }
+ } else {
+ token->prevPtr->nextPtr = token->nextPtr;
+ if (token == lastHandler) {
+ lastHandler = token->prevPtr;
+ }
+ }
+ if (token->nextPtr != NULL) {
+ token->nextPtr->prevPtr = token->prevPtr;
+ }
+ token->nextPtr = toDelete;
+ token->prevPtr = NULL;
+ toDelete = token;
+ }
+ token = nextToken;
+ }
+ Tcl_MutexUnlock(&asyncMutex);
+ while (toDelete != NULL) {
+ token = toDelete;
+ toDelete = toDelete->nextPtr;
+ ckfree(token);
}
}
@@ -118,22 +147,25 @@ Tcl_AsyncCreate(
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- asyncPtr = (AsyncHandler *)ckalloc(sizeof(AsyncHandler));
+ asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
+ asyncPtr->prevPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
+ asyncPtr->notifierData = TclpNotifierData();
- Tcl_MutexLock(&tsdPtr->asyncMutex);
- if (tsdPtr->firstHandler == NULL) {
- tsdPtr->firstHandler = asyncPtr;
+ Tcl_MutexLock(&asyncMutex);
+ if (firstHandler == NULL) {
+ firstHandler = asyncPtr;
} else {
- tsdPtr->lastHandler->nextPtr = asyncPtr;
+ asyncPtr->prevPtr = lastHandler;
+ lastHandler->nextPtr = asyncPtr;
}
- tsdPtr->lastHandler = asyncPtr;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ lastHandler = asyncPtr;
+ Tcl_MutexUnlock(&asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
@@ -162,13 +194,86 @@ Tcl_AsyncMark(
{
AsyncHandler *token = (AsyncHandler *) async;
- Tcl_MutexLock(&token->originTsd->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
token->ready = 1;
if (!token->originTsd->asyncActive) {
token->originTsd->asyncReady = 1;
Tcl_ThreadAlert(token->originThrdId);
}
- Tcl_MutexUnlock(&token->originTsd->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncMarkFromSignal --
+ *
+ * This procedure is similar to Tcl_AsyncMark but must be used
+ * in POSIX signal contexts. In addition to Tcl_AsyncMark the
+ * signal number is passed.
+ *
+ * Results:
+ * True, when the handler will be marked, false otherwise.
+ *
+ * Side effects:
+ * The handler gets marked for invocation later.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AsyncMarkFromSignal(
+ Tcl_AsyncHandler async, /* Token for handler. */
+ int sigNumber) /* Signal number. */
+{
+#if TCL_THREADS
+ AsyncHandler *token = (AsyncHandler *) async;
+
+ return TclAsyncNotifier(sigNumber, token->originThrdId,
+ token->notifierData, &token->ready, -1);
+#else
+ (void)sigNumber;
+
+ Tcl_AsyncMark(async);
+ return 1;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclAsyncMarkFromNotifier --
+ *
+ * This procedure is called from the notifier thread and
+ * invokes Tcl_AsyncMark for specifically marked handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Handlers get marked for invocation later.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclAsyncMarkFromNotifier(void)
+{
+ AsyncHandler *token;
+
+ Tcl_MutexLock(&asyncMutex);
+ for (token = firstHandler; token != NULL;
+ token = token->nextPtr) {
+ if (token->ready == -1) {
+ token->ready = 1;
+ if (!token->originTsd->asyncActive) {
+ token->originTsd->asyncReady = 1;
+ Tcl_ThreadAlert(token->originThrdId);
+ }
+ }
+ }
+ Tcl_MutexUnlock(&asyncMutex);
}
/*
@@ -200,11 +305,12 @@ Tcl_AsyncInvoke(
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
- Tcl_MutexLock(&tsdPtr->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
if (tsdPtr->asyncReady == 0) {
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
tsdPtr->asyncReady = 0;
@@ -224,8 +330,11 @@ Tcl_AsyncInvoke(
*/
while (1) {
- for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->originThrdId != self) {
+ continue;
+ }
if (asyncPtr->ready) {
break;
}
@@ -234,12 +343,12 @@ Tcl_AsyncInvoke(
break;
}
asyncPtr->ready = 0;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
code = asyncPtr->proc(asyncPtr->clientData, interp, code);
- Tcl_MutexLock(&tsdPtr->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
}
tsdPtr->asyncActive = 0;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
@@ -271,9 +380,7 @@ void
Tcl_AsyncDelete(
Tcl_AsyncHandler async) /* Token for handler to delete. */
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
- AsyncHandler *prevPtr, *thisPtr;
/*
* Assure early handling of the constraint
@@ -283,33 +390,22 @@ Tcl_AsyncDelete(
Tcl_Panic("Tcl_AsyncDelete: async handler deleted by the wrong thread");
}
- /*
- * If we come to this point when TSD's for the current
- * thread have already been garbage-collected, we are
- * in the _serious_ trouble. OTOH, we tolerate calling
- * with already cleaned-up handler list (should we?).
- */
-
- Tcl_MutexLock(&tsdPtr->asyncMutex);
- if (tsdPtr->firstHandler != NULL) {
- prevPtr = thisPtr = tsdPtr->firstHandler;
- while (thisPtr != NULL && thisPtr != asyncPtr) {
- prevPtr = thisPtr;
- thisPtr = thisPtr->nextPtr;
- }
- if (thisPtr == NULL) {
- Tcl_Panic("Tcl_AsyncDelete: cannot find async handler");
+ Tcl_MutexLock(&asyncMutex);
+ if (asyncPtr->prevPtr == NULL) {
+ firstHandler = asyncPtr->nextPtr;
+ if (firstHandler == NULL) {
+ lastHandler = NULL;
}
- if (asyncPtr == tsdPtr->firstHandler) {
- tsdPtr->firstHandler = asyncPtr->nextPtr;
- } else {
- prevPtr->nextPtr = asyncPtr->nextPtr;
- }
- if (asyncPtr == tsdPtr->lastHandler) {
- tsdPtr->lastHandler = prevPtr;
+ } else {
+ asyncPtr->prevPtr->nextPtr = asyncPtr->nextPtr;
+ if (asyncPtr == lastHandler) {
+ lastHandler = asyncPtr->prevPtr;
}
}
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ if (asyncPtr->nextPtr != NULL) {
+ asyncPtr->nextPtr->prevPtr = asyncPtr->prevPtr;
+ }
+ Tcl_MutexUnlock(&asyncMutex);
ckfree(asyncPtr);
}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9243539..a31bfb6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -5,13 +5,13 @@
* including interpreter creation and deletion, command creation and
* deletion, and command/script execution.
*
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * 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>
+ * Copyright © 1987-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
+ * Copyright © 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.
@@ -20,10 +20,50 @@
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
+/*
+ * TCL_FPCLASSIFY_MODE:
+ * 0 - fpclassify
+ * 1 - _fpclass
+ * 2 - simulate
+ * 3 - __builtin_fpclassify
+ */
+
+#ifndef TCL_FPCLASSIFY_MODE
+#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */
+/*
+ * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify,
+ * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a
+ * version using a compiler built-in.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#elif defined(fpclassify) /* fpclassify */
+/*
+ * This is the C99 standard.
+ */
+#include <float.h>
+#define TCL_FPCLASSIFY_MODE 0
+#elif defined(_FPCLASS_NN) /* _fpclass */
+/*
+ * This case handles newer MSVC on Windows, which doesn't have the standard
+ * operation but does have something that can tell us the same thing.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#else /* !fpclassify && !_fpclass (older MSVC), simulate */
+/*
+ * Older MSVC on Windows. So broken that we just have to do it our way. This
+ * assumes that we're on x86 (or at least a system with classic little-endian
+ * double layout and a 32-bit 'int' type).
+ */
+#define TCL_FPCLASSIFY_MODE 2
+#endif /* !fpclassify */
+/* actually there is no fallback to builtin fpclassify */
+#endif /* !TCL_FPCLASSIFY_MODE */
+
+
#define INTERP_STACK_INITIAL_SIZE 2000
#define CORO_STACK_INITIAL_SIZE 200
@@ -46,7 +86,7 @@ typedef struct OldMathFuncData {
Tcl_MathProc *proc; /* Handler function */
int numArgs; /* Number of args expected */
Tcl_ValueType *argTypes; /* Types of the args */
- ClientData clientData; /* Client data for the handler function */
+ void *clientData; /* Client data for the handler function */
} OldMathFuncData;
/*
@@ -65,13 +105,24 @@ typedef struct {
* 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 length; /* Length of the above error message. */
+ void *clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
-TCL_DECLARE_MUTEX(cancelLock)
+TCL_DECLARE_MUTEX(cancelLock);
+
+/*
+ * Table used to map command implementation functions to a human-readable type
+ * name, for [info type]. The keys in the table are function addresses, and
+ * the values in the table are static char* containing strings in Tcl's
+ * internal encoding (almost UTF-8).
+ */
+
+static Tcl_HashTable commandTypeTable;
+static int commandTypeInit = 0;
+TCL_DECLARE_MUTEX(commandTypeLock);
/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
@@ -94,15 +145,16 @@ TCL_DECLARE_MUTEX(cancelLock)
* Static functions in this file:
*/
+static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
-static int CancelEvalProc(ClientData clientData,
+static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
-static void DeleteCoroutine(ClientData clientData);
+static void DeleteCoroutine(void *clientData);
static void DeleteInterpProc(Tcl_Interp *interp);
-static void DeleteOpCmdClientData(ClientData clientData);
+static void DeleteOpCmdClientData(void *clientData);
#ifdef USE_DTRACE
static Tcl_ObjCmdProc DTraceObjCmd;
static Tcl_NRPostProc DTraceCmdReturn;
@@ -114,24 +166,34 @@ 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 ExprIsFiniteFunc;
+static Tcl_ObjCmdProc ExprIsInfinityFunc;
+static Tcl_ObjCmdProc ExprIsNaNFunc;
+static Tcl_ObjCmdProc ExprIsNormalFunc;
+static Tcl_ObjCmdProc ExprIsSubnormalFunc;
+static Tcl_ObjCmdProc ExprIsUnorderedFunc;
+static Tcl_ObjCmdProc ExprMaxFunc;
+static Tcl_ObjCmdProc ExprMinFunc;
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_ObjCmdProc FloatClassifyObjCmd;
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
+#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
-static void OldMathFuncDeleteProc(ClientData clientData);
+static void OldMathFuncDeleteProc(void *clientData);
+#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
@@ -156,9 +218,13 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc EvalObjvCore;
static Tcl_NRPostProc Dispatch;
-static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_ObjCmdProc NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
+static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
+static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
+static Tcl_NRPostProc InjectHandler;
+static Tcl_NRPostProc InjectHandlerPostCall;
MODULE_SCOPE const TclStubs tclStubs;
@@ -167,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs;
* after particular kinds of [yield].
*/
-#define CORO_ACTIVATE_YIELD PTR2INT(NULL)
-#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1
+#define CORO_ACTIVATE_YIELD NULL
+#define CORO_ACTIVATE_YIELDM INT2PTR(1)
#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1)
#define COROUTINE_ARGUMENTS_ARBITRARY (-2)
@@ -193,6 +259,24 @@ typedef struct {
* it for it. Defined in tclInt.h. */
/*
+ * The following struct states that the command it talks about (a subcommand
+ * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an
+ * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these
+ * structs.) Alas, we can't sensibly just store the information directly in
+ * the commands.
+ */
+
+typedef struct {
+ const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for
+ * the end of the list of commands to hide. */
+ const char *commandName; /* The name of the command within the
+ * ensemble. If this is NULL, we want to also
+ * make the overall command be hidden, an ugly
+ * hack because it is expected by security
+ * policies in the wild. */
+} UnsafeEnsembleInfo;
+
+/*
* The built-in commands, and the functions that implement them:
*/
@@ -204,12 +288,14 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef EXCLUDE_OBSOLETE_COMMANDS
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
{"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
+ {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE},
+ {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
{"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE},
@@ -217,22 +303,27 @@ static const CmdInfo builtInCmds[] = {
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE},
{"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE},
+ {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE},
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE},
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE},
{"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
+ {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
{"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
+ {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
@@ -286,9 +377,7 @@ static const CmdInfo builtInCmds[] = {
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
-#ifdef TCL_TIMERATE
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
-#endif
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -296,6 +385,69 @@ static const CmdInfo builtInCmds[] = {
};
/*
+ * Information about which pieces of ensembles to hide when making an
+ * interpreter safe:
+ */
+
+static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
+ /* [encoding] has two unsafe commands. Assumed by older security policies
+ * to be overall unsafe; it isn't but... */
+ {"encoding", NULL},
+ {"encoding", "dirs"},
+ {"encoding", "system"},
+ /* [file] has MANY unsafe commands! Assumed by older security policies to
+ * be overall unsafe; it isn't but... */
+ {"file", NULL},
+ {"file", "atime"},
+ {"file", "attributes"},
+ {"file", "copy"},
+ {"file", "delete"},
+ {"file", "dirname"},
+ {"file", "executable"},
+ {"file", "exists"},
+ {"file", "extension"},
+ {"file", "isdirectory"},
+ {"file", "isfile"},
+ {"file", "link"},
+ {"file", "lstat"},
+ {"file", "mtime"},
+ {"file", "mkdir"},
+ {"file", "nativename"},
+ {"file", "normalize"},
+ {"file", "owned"},
+ {"file", "readable"},
+ {"file", "readlink"},
+ {"file", "rename"},
+ {"file", "rootname"},
+ {"file", "size"},
+ {"file", "stat"},
+ {"file", "tail"},
+ {"file", "tempdir"},
+ {"file", "tempfile"},
+ {"file", "type"},
+ {"file", "volumes"},
+ {"file", "writable"},
+ /* [info] has two unsafe commands */
+ {"info", "cmdtype"},
+ {"info", "nameofexecutable"},
+ /* [tcl::process] has ONLY unsafe commands! */
+ {"process", "list"},
+ {"process", "status"},
+ {"process", "purge"},
+ {"process", "autopurge"},
+ /* [zipfs] has MANY unsafe commands! */
+ {"zipfs", "lmkimg"},
+ {"zipfs", "lmkzip"},
+ {"zipfs", "mkimg"},
+ {"zipfs", "mkkey"},
+ {"zipfs", "mkzip"},
+ {"zipfs", "mount"},
+ {"zipfs", "mount_data"},
+ {"zipfs", "unmount"},
+ {NULL, NULL}
+};
+
+/*
* Math functions. All are safe.
*/
@@ -303,37 +455,45 @@ typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
- ClientData clientData; /* Client data for the function */
+ double (*fn)(double x); /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
- { "acos", ExprUnaryFunc, (ClientData) acos },
- { "asin", ExprUnaryFunc, (ClientData) asin },
- { "atan", ExprUnaryFunc, (ClientData) atan },
- { "atan2", ExprBinaryFunc, (ClientData) atan2 },
+ { "acos", ExprUnaryFunc, acos },
+ { "asin", ExprUnaryFunc, asin },
+ { "atan", ExprUnaryFunc, atan },
+ { "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) atan2},
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
- { "cos", ExprUnaryFunc, (ClientData) cos },
- { "cosh", ExprUnaryFunc, (ClientData) cosh },
+ { "cos", ExprUnaryFunc, cos },
+ { "cosh", ExprUnaryFunc, cosh },
{ "double", ExprDoubleFunc, NULL },
- { "entier", ExprEntierFunc, NULL },
- { "exp", ExprUnaryFunc, (ClientData) exp },
+ { "entier", ExprIntFunc, NULL },
+ { "exp", ExprUnaryFunc, exp },
{ "floor", ExprFloorFunc, NULL },
- { "fmod", ExprBinaryFunc, (ClientData) fmod },
- { "hypot", ExprBinaryFunc, (ClientData) hypot },
+ { "fmod", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) fmod},
+ { "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) hypot},
{ "int", ExprIntFunc, NULL },
+ { "isfinite", ExprIsFiniteFunc, NULL },
+ { "isinf", ExprIsInfinityFunc, NULL },
+ { "isnan", ExprIsNaNFunc, NULL },
+ { "isnormal", ExprIsNormalFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
- { "log", ExprUnaryFunc, (ClientData) log },
- { "log10", ExprUnaryFunc, (ClientData) log10 },
- { "pow", ExprBinaryFunc, (ClientData) pow },
+ { "issubnormal", ExprIsSubnormalFunc, NULL, },
+ { "isunordered", ExprIsUnorderedFunc, NULL, },
+ { "log", ExprUnaryFunc, log },
+ { "log10", ExprUnaryFunc, log10 },
+ { "max", ExprMaxFunc, NULL },
+ { "min", ExprMinFunc, NULL },
+ { "pow", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) pow},
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
- { "sin", ExprUnaryFunc, (ClientData) sin },
- { "sinh", ExprUnaryFunc, (ClientData) sinh },
+ { "sin", ExprUnaryFunc, sin },
+ { "sinh", ExprUnaryFunc, sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
- { "tan", ExprUnaryFunc, (ClientData) tan },
- { "tanh", ExprUnaryFunc, (ClientData) tanh },
+ { "tan", ExprUnaryFunc, tan },
+ { "tanh", ExprUnaryFunc, tanh },
{ "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
@@ -400,6 +560,14 @@ static const OpCmdInfo mathOpCmds[] = {
/* unused */ {0}, NULL},
{ "eq", TclSortingOpCmd, TclCompileStreqOpCmd,
/* unused */ {0}, NULL},
+ { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd,
+ /* unused */ {0}, NULL},
+ { "le", TclSortingOpCmd, TclCompileStrLeOpCmd,
+ /* unused */ {0}, NULL},
+ { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd,
+ /* unused */ {0}, NULL},
+ { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd,
+ /* unused */ {0}, NULL},
{ NULL, NULL, NULL,
{0}, NULL}
};
@@ -429,11 +597,120 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
*----------------------------------------------------------------------
*
+ * buildInfoObjCmd --
+ *
+ * Implements tcl::build-info command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+buildInfoObjCmd(
+ void *clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?option?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ int len;
+ const char *arg = TclGetStringFromObj(objv[1], &len);
+ if (len == 7 && !strcmp(arg, "version")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '.');
+ if (p) {
+ const char *q = strchr(p+1, '.');
+ const char *r = strchr(p+1, '+');
+ p = (q < r) ? q : r;
+ }
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 10 && !strcmp(arg, "patchlevel")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '+');
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 6 && !strcmp(arg, "commit")) {
+ const char *q, *p = strchr((char *)clientData, '+');
+ if (p) {
+ if ((q = strchr(p, '.'))) {
+ char buf[80];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ }
+ return TCL_OK;
+ } else if (len == 8 && !strcmp(arg, "compiler")) {
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4)
+ || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) {
+ const char *q = strchr(p+1, '.');
+ if (q) {
+ char buf[16];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) {
+ Tcl_AppendResult(interp, "1", NULL);
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, (char *)clientData, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -471,7 +748,7 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
- const char *version = TclInitSubsystems();
+ const char *version = Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -489,8 +766,8 @@ Tcl_CreateInterp(void)
* the same way. Therefore, this is not officially supported.
* In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
*/
- if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
- || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
+ if ((offsetof(Tcl_StatBuf,st_atime) != 32)
+ || (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
@@ -505,6 +782,20 @@ Tcl_CreateInterp(void)
Tcl_MutexUnlock(&cancelLock);
}
+#undef TclObjInterpProc
+ if (commandTypeInit == 0) {
+ TclRegisterCommandTypeName(TclObjInterpProc, "proc");
+ TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
+ TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclChildObjCmd, "interp");
+ TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
+ TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
+ TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
+ TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
+ TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -514,7 +805,11 @@ Tcl_CreateInterp(void)
iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
+#ifdef TCL_NO_DEPRECATED
+ iPtr->result = &tclEmptyString;
+#else
iPtr->result = iPtr->resultSpace;
+#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
TclNewObj(iPtr->objResultPtr);
@@ -574,9 +869,11 @@ Tcl_CreateInterp(void)
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
+#ifndef TCL_NO_DEPRECATED
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
+#endif
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
@@ -586,15 +883,16 @@ Tcl_CreateInterp(void)
#endif
/* TIP #268 */
+#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
iPtr->packagePrefer = PKG_PREFER_STABLE;
- } else {
+ } else
+#endif
iPtr->packagePrefer = PKG_PREFER_LATEST;
- }
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
- iPtr->compileEpoch = 0;
+ iPtr->compileEpoch = 1;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
@@ -606,10 +904,11 @@ Tcl_CreateInterp(void)
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
- TclNewObj(iPtr->emptyObjPtr);
- /* Another empty object. */
+ TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
+#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
+#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
@@ -742,7 +1041,7 @@ Tcl_CreateInterp(void)
* cache was already initialised by the call to alloc the interp struct.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
@@ -812,6 +1111,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -852,14 +1152,10 @@ Tcl_CreateInterp(void)
/* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
- NRCoroInjectObjCmd, NULL, NULL);
+ NRInjectObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
CoroTypeObjCmd, NULL, NULL);
- /* Create an unsupported command for timerate */
- Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate",
- Tcl_TimeRateObjCmd, NULL, NULL);
-
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
@@ -889,7 +1185,7 @@ Tcl_CreateInterp(void)
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
- builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
+ builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
@@ -951,24 +1247,26 @@ Tcl_CreateInterp(void)
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
- Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY);
/* TIP #291 */
Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
- Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY);
/*
* Set up other variables such as tcl_version and tcl_library
*/
- Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
+#endif /* !TCL_NO_DEPRECATED */
TclpSetVariables(interp);
-#ifdef TCL_THREADS
+#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
@@ -982,16 +1280,21 @@ Tcl_CreateInterp(void)
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
+ * TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...."
*/
- Tcl_PkgProvideEx(interp, "Tcl", version, &tclStubs);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_CreateObjCommand(interp, "::tcl::build-info",
+ buildInfoObjCmd, (void *)version, NULL);
+
if (TclTommath_Init(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
@@ -1001,6 +1304,9 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
+ }
+ if (TclZipfs_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
#endif
@@ -1011,7 +1317,7 @@ Tcl_CreateInterp(void)
static void
DeleteOpCmdClientData(
- ClientData clientData)
+ void *clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
@@ -1019,6 +1325,71 @@ DeleteOpCmdClientData(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclRegisterCommandTypeName, TclGetCommandTypeName --
+ *
+ * Command type registration and lookup mechanism. Everything is keyed by
+ * the Tcl_ObjCmdProc for the command, and that is used as the *key* into
+ * the hash table that maps to constant strings that are names. (It is
+ * recommended that those names be ASCII.)
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr)
+{
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit == 0) {
+ Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
+ commandTypeInit = 1;
+ }
+ if (nameStr != NULL) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&commandTypeTable,
+ implementationProc, &isNew);
+ Tcl_SetHashValue(hPtr, (void *) nameStr);
+ } else {
+ hPtr = Tcl_FindHashEntry(&commandTypeTable,
+ implementationProc);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+}
+
+const char *
+TclGetCommandTypeName(
+ Tcl_Command command)
+{
+ Command *cmdPtr = (Command *) command;
+ Tcl_ObjCmdProc *procPtr = cmdPtr->objProc;
+ const char *name = "native";
+
+ if (procPtr == NULL) {
+ procPtr = cmdPtr->nreProc;
+ }
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
+
+ if (hPtr && Tcl_GetHashValue(hPtr)) {
+ name = (const char *) Tcl_GetHashValue(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+
+ return name;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
@@ -1039,6 +1410,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1048,12 +1420,83 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
- TclMakeEncodingCommandSafe(interp); /* Ugh! */
- TclMakeFileCommandSafe(interp); /* Ugh! */
+
+ for (unsafePtr = unsafeEnsembleCommands;
+ unsafePtr->ensembleNsName; unsafePtr++) {
+ if (unsafePtr->commandName) {
+ /*
+ * Hide an ensemble subcommand.
+ */
+
+ Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+ Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+
+ if (TclRenameCommand(interp, TclGetString(cmdName),
+ "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp",
+ TclGetString(hideName)) != TCL_OK) {
+ Tcl_Panic("problem making '%s %s' safe: %s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ Tcl_CreateObjCommand(interp, TclGetString(cmdName),
+ BadEnsembleSubcommand, (void *)unsafePtr, NULL);
+ TclDecrRefCount(cmdName);
+ TclDecrRefCount(hideName);
+ } else {
+ /*
+ * Hide an ensemble main command (for compatibility).
+ */
+
+ if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
+ unsafePtr->ensembleNsName) != TCL_OK) {
+ Tcl_Panic("problem making '%s' safe: %s",
+ unsafePtr->ensembleNsName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ }
+ }
+
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * BadEnsembleSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * ensembles are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is description of what was hidden.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadEnsembleSubcommand(
+ void *clientData,
+ Tcl_Interp *interp,
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /* objv */)
+{
+ const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of %s",
+ infoPtr->commandName, infoPtr->ensembleNsName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
@@ -1079,7 +1522,7 @@ Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
@@ -1127,7 +1570,7 @@ Tcl_DontCallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTablePtr;
@@ -1175,7 +1618,7 @@ Tcl_SetAssocData(
const char *name, /* Name for association. */
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
* be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
@@ -1257,7 +1700,7 @@ Tcl_DeleteAssocData(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetAssocData(
Tcl_Interp *interp, /* Interpreter associated with. */
const char *name, /* Name of association. */
@@ -1425,7 +1868,7 @@ DeleteInterpProc(
*/
Tcl_MutexLock(&cancelLock);
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ hPtr = Tcl_FindHashEntry(&cancelTable, iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
@@ -1491,28 +1934,28 @@ DeleteInterpProc(
ckfree(hTablePtr);
}
- /*
- * Invoke deletion callbacks; note that a callback can create new
- * callbacks, so we iterate.
- */
- while (iPtr->assocData != NULL) {
+ if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
- iPtr->assocData = NULL;
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
+ Tcl_DeleteHashEntry(hPtr);
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
+ iPtr->assocData = NULL;
}
/*
@@ -1533,8 +1976,10 @@ DeleteInterpProc(
* could have transferred ownership of the result string to Tcl.
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_FreeResult(interp);
iPtr->result = NULL;
+#endif
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
Tcl_DecrRefCount(iPtr->ecVar);
@@ -1556,10 +2001,12 @@ DeleteInterpProc(
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
+#ifndef TCL_NO_DEPRECATED
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
+#endif
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
@@ -1626,7 +2073,7 @@ DeleteInterpProc(
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
- for (i=0; i< eclPtr->nuloc; i++) {
+ for (i=0; i<eclPtr->nuloc; i++) {
ckfree(eclPtr->loc[i].line);
}
@@ -1657,7 +2104,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -2057,7 +2504,7 @@ Tcl_CreateCommand(
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
- ClientData clientData, /* Arbitrary value passed to string proc. */
+ void *clientData, /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
@@ -2245,6 +2692,66 @@ Tcl_CreateCommand(
*----------------------------------------------------------------------
*/
+typedef struct {
+ Tcl_ObjCmdProc2 *proc;
+ void *clientData; /* Arbitrary value to pass to proc function. */
+ Tcl_CmdDeleteProc *deleteProc;
+ void *deleteData; /* Arbitrary value to pass to deleteProc function. */
+ Tcl_ObjCmdProc2 *nreProc;
+} CmdWrapperInfo;
+
+
+static int cmdWrapperProc(void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const *objv)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1;
+ }
+ return info->proc(info->clientData, interp, objc, objv);
+}
+
+static void cmdWrapperDeleteProc(void *clientData) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+
+ clientData = info->deleteData;
+ Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
+ ckfree(info);
+ if (deleteProc != NULL) {
+ deleteProc(clientData);
+ }
+}
+
+Tcl_Command
+Tcl_CreateObjCommand2(
+ 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_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name. */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->clientData = clientData;
+ info->deleteProc = deleteProc;
+ info->deleteData = clientData;
+
+ return Tcl_CreateObjCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -2255,7 +2762,7 @@ Tcl_CreateObjCommand(
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
@@ -2305,7 +2812,7 @@ TclCreateObjCommandInNs(
Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
@@ -2448,7 +2955,10 @@ TclCreateObjCommandInNs(
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
+
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
+ cmdPtr->refCount++;
+ TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -2488,7 +2998,7 @@ TclCreateObjCommandInNs(
int
TclInvokeStringCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2499,7 +3009,7 @@ TclInvokeStringCommand(
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
+ argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
@@ -2536,7 +3046,7 @@ TclInvokeStringCommand(
int
TclInvokeObjectCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2753,7 +3263,7 @@ TclRenameCommand(
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
- CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
+ CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -2875,8 +3385,14 @@ Tcl_SetCommandInfoFromToken(
}
cmdPtr->objClientData = infoPtr->objClientData;
}
- cmdPtr->deleteProc = infoPtr->deleteProc;
- cmdPtr->deleteData = infoPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ info->deleteProc = infoPtr->deleteProc;
+ info->deleteData = infoPtr->deleteData;
+ } else {
+ cmdPtr->deleteProc = infoPtr->deleteProc;
+ cmdPtr->deleteData = infoPtr->deleteData;
+ }
return 1;
}
@@ -2953,10 +3469,15 @@ Tcl_GetCommandInfoFromToken(
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
- infoPtr->deleteProc = cmdPtr->deleteProc;
- infoPtr->deleteData = cmdPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ infoPtr->deleteProc = info->deleteProc;
+ infoPtr->deleteData = info->deleteData;
+ } else {
+ infoPtr->deleteProc = cmdPtr->deleteProc;
+ infoPtr->deleteData = cmdPtr->deleteData;
+ }
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-
return 1;
}
@@ -2979,7 +3500,7 @@ Tcl_GetCommandInfoFromToken(
const char *
Tcl_GetCommandName(
- Tcl_Interp *interp, /* Interpreter containing the command. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Command command) /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
@@ -3038,7 +3559,7 @@ Tcl_GetCommandFullName(
* separator, and the command name.
*/
- if (cmdPtr != NULL) {
+ if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
@@ -3120,13 +3641,6 @@ Tcl_DeleteCommandFromToken(
Tcl_Command importCmd;
/*
- * Bump the command epoch counter. This will invalidate all cached
- * references that point to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
* The code here is tricky. We can't delete the hash table entry before
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
@@ -3135,7 +3649,7 @@ Tcl_DeleteCommandFromToken(
* and skip nested deletes.
*/
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* Another deletion is already in progress. Remove the hash table
* entry now, but don't invoke a callback or free the command
@@ -3148,6 +3662,14 @@ Tcl_DeleteCommandFromToken(
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
return 0;
}
@@ -3159,17 +3681,18 @@ Tcl_DeleteCommandFromToken(
* be ignored.
*/
- cmdPtr->flags |= CMD_IS_DELETED;
+ cmdPtr->flags |= CMD_DYING;
/*
- * Call trace functions for the command being deleted. Then delete its
- * traces.
+ * Call each functions and then delete the trace.
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
+ /* CallCommandTraces() does not cmdPtr, that's
+ * done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
/*
@@ -3324,7 +3847,7 @@ CallCommandTraces(
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
- * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
+ * (cmdPtr->flags & CMD_DYING) and returns immediately when a
* command deletion is in progress. For all other traces, delete
* traces will not be invoked but a call to TraceCommandProc will
* ensure that tracePtr->clientData is freed whenever the command
@@ -3423,8 +3946,8 @@ CallCommandTraces(
static int
CancelEvalProc(
- ClientData clientData, /* Interp to cancel the script in progress. */
- Tcl_Interp *interp, /* Ignored */
+ void *clientData, /* Interp to cancel the script in progress. */
+ TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
CancelInfo *cancelInfo = (CancelInfo *)clientData;
@@ -3531,6 +4054,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3542,7 +4066,7 @@ Tcl_CreateMathFunc(
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
- ClientData clientData) /* Additional value to pass to the
+ void *clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
@@ -3583,7 +4107,7 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Pointer to OldMathFuncData describing the
+ void *clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
@@ -3611,13 +4135,18 @@ OldMathFuncProc(
args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
- /* TODO: Convert to TclGetNumberFromObj? */
+ /* TODO: Convert to Tcl_GetNumberFromObj? */
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
- if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
- d = valuePtr->internalRep.doubleValue;
- result = TCL_OK;
+ if (result != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(valuePtr, &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ result = TCL_OK;
+ }
}
#endif
if (result != TCL_OK) {
@@ -3628,7 +4157,7 @@ OldMathFuncProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
- TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
+ TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
@@ -3696,9 +4225,9 @@ OldMathFuncProc(
*/
if (funcResult.type == TCL_INT) {
- TclNewLongObj(valuePtr, funcResult.intValue);
+ TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
- valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
+ TclNewIntObj(valuePtr, funcResult.wideValue);
} else {
return CheckDoubleResult(interp, funcResult.doubleValue);
}
@@ -3725,7 +4254,7 @@ OldMathFuncProc(
static void
OldMathFuncDeleteProc(
- ClientData clientData)
+ void *clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
@@ -3764,7 +4293,7 @@ Tcl_GetMathFuncInfo(
int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Tcl_Obj *cmdNameObj;
Command *cmdPtr;
@@ -3864,6 +4393,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -3926,7 +4456,7 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
+ if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
@@ -4048,7 +4578,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4105,7 +4635,7 @@ Tcl_CancelEval(
* script. */
Tcl_Obj *resultObjPtr, /* The script cancellation error message or
* NULL for a default error message. */
- ClientData clientData, /* Passed to CancelEvalProc. */
+ void *clientData, /* Passed to CancelEvalProc. */
int flags) /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
@@ -4128,7 +4658,7 @@ Tcl_CancelEval(
goto done;
}
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+ hPtr = Tcl_FindHashEntry(&cancelTable, interp);
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
@@ -4147,7 +4677,7 @@ Tcl_CancelEval(
*/
if (resultObjPtr != NULL) {
- result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
+ result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
@@ -4264,9 +4794,9 @@ TclNREvalObjv(
static int
EvalObjvCore(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
@@ -4424,12 +4954,12 @@ EvalObjvCore(
static int
Dispatch(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
- ClientData clientData = data[1];
+ void *clientData = data[1];
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
@@ -4475,7 +5005,9 @@ TclNRRunCallbacks(
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4487,9 +5019,11 @@ TclNRRunCallbacks(
* are for NR function calls, and those are Tcl_Obj based.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* This is the trampoline.
@@ -4508,11 +5042,12 @@ TclNRRunCallbacks(
static int
NRCommand(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
iPtr->numLevels--;
@@ -4521,7 +5056,10 @@ NRCommand(
*/
if (data[1] && (data[1] != INT2PTR(1))) {
- TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ listPtr = (Tcl_Obj *)data[1];
+ data[1] = NULL;
+
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL);
}
/* OPT ??
@@ -4608,7 +5146,7 @@ TEOV_SwitchVarFrame(
static int
TEOV_RestoreVarFrame(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4618,7 +5156,7 @@ TEOV_RestoreVarFrame(
static int
TEOV_Exception(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4647,7 +5185,7 @@ TEOV_Exception(
static int
TEOV_Error(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4666,7 +5204,7 @@ TEOV_Error(
*/
listPtr = Tcl_NewListObj(objc, objv);
- cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
+ cmdString = TclGetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
@@ -4715,7 +5253,7 @@ TEOV_NotFound(
* itself.
*/
- TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
+ TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
@@ -4773,7 +5311,7 @@ TEOV_NotFound(
static int
TEOV_NotFoundCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4810,9 +5348,9 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
- int length, traceCode = TCL_OK;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int traceCode = TCL_OK;
+ const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4853,7 +5391,7 @@ TEOV_RunEnterTraces(
static int
TEOV_RunLeaveTraces(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4864,9 +5402,9 @@ TEOV_RunLeaveTraces(
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ const char *command = TclGetStringFromObj(commandPtr, &length);
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -4953,6 +5491,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -5000,6 +5539,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5073,12 +5613,13 @@ TclEvalEx(
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
- int commandLength, bytesLeft, expandRequested, code = TCL_OK;
+ int bytesLeft, expandRequested, code = TCL_OK;
+ int commandLength;
CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
- unsigned int i, objectsUsed = 0;
+ TCL_HASH_TYPE i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
@@ -5270,7 +5811,7 @@ TclEvalEx(
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
int numElements;
- code = TclListObjLength(interp, objv[objectsUsed],
+ code = TclListObjLengthM(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
@@ -5322,7 +5863,7 @@ TclEvalEx(
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
- TclListObjGetElements(NULL, temp, &numElements,
+ TclListObjGetElementsM(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
@@ -5683,7 +6224,7 @@ TclArgumentRelease(
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
+ Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
@@ -5735,7 +6276,7 @@ TclArgumentBCEnter(
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
@@ -5841,7 +6382,7 @@ TclArgumentBCRelease(
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
@@ -5897,7 +6438,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -5906,7 +6447,7 @@ TclArgumentGet(
* stack. That is nearest.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
@@ -5920,7 +6461,7 @@ TclArgumentGet(
* that stack.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
@@ -5955,6 +6496,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -5962,7 +6504,7 @@ Tcl_Eval(
* previous call to Tcl_CreateInterp). */
const char *script) /* Pointer to TCL command to execute. */
{
- int code = Tcl_EvalEx(interp, script, -1, 0);
+ int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0);
/*
* For backwards compatibility with old C code that predates the object
@@ -6007,6 +6549,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6160,7 +6703,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6228,7 +6771,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6240,7 +6783,7 @@ TclNREvalObjEx(
static int
TEOEx_ByteCodeCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6259,7 +6802,7 @@ TEOEx_ByteCodeCallback(
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6286,7 +6829,7 @@ TEOEx_ByteCodeCallback(
static int
TEOEx_ListCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6493,14 +7036,14 @@ Tcl_ExprLongObj(
Tcl_Obj *resultPtr;
int result, type;
double d;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) {
return TCL_ERROR;
}
@@ -6516,8 +7059,7 @@ Tcl_ExprLongObj(
resultPtr = Tcl_NewBignumObj(&big);
}
/* FALLTHRU */
- case TCL_NUMBER_LONG:
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
@@ -6540,14 +7082,14 @@ Tcl_ExprDoubleObj(
{
Tcl_Obj *resultPtr;
int result, type;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
- result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type);
+ result = Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type);
if (result == TCL_OK) {
switch (type) {
case TCL_NUMBER_NAN:
@@ -6678,7 +7220,7 @@ TclObjInvoke(
int
TclNRInvoke(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6721,7 +7263,7 @@ TclNRInvoke(
static int
NRPostInvoke(
- ClientData clientData[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -6764,7 +7306,7 @@ Tcl_ExprString(
* An empty string. Just set the interpreter's result to 0.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
@@ -6838,6 +7380,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6847,6 +7390,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6887,7 +7431,8 @@ Tcl_AddObjErrorInfo(
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
- if (iPtr->result[0] != 0) {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ if (*(iPtr->result) != 0) {
/*
* The interp's string result is set, apparently by some extension
* making a deprecated direct write to it. That extension may
@@ -6897,9 +7442,9 @@ Tcl_AddObjErrorInfo(
*/
iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
- } else {
+ } else
+#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
- }
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
@@ -6921,7 +7466,7 @@ Tcl_AddObjErrorInfo(
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
@@ -6930,12 +7475,12 @@ Tcl_AddObjErrorInfo(
*
* Results:
* A standard Tcl return result. An error message or other result may be
- * left in the interp's result.
+ * left in the interp.
*
* Side effects:
* Depends on what was done by the command.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
@@ -6962,7 +7507,7 @@ Tcl_VarEvalVA(
Tcl_DStringAppend(&buf, string, -1);
}
- result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
+ result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
@@ -6984,6 +7529,7 @@ Tcl_VarEvalVA(
*
*----------------------------------------------------------------------
*/
+
int
Tcl_VarEval(
Tcl_Interp *interp,
@@ -7018,6 +7564,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -7031,10 +7578,11 @@ Tcl_GlobalEval(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
- result = Tcl_Eval(interp, command);
+ result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -7156,7 +7704,7 @@ Tcl_GetVersion(
static int
ExprCeilFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7172,9 +7720,13 @@ ExprCeilFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7192,7 +7744,7 @@ ExprCeilFunc(
static int
ExprFloorFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7208,9 +7760,13 @@ ExprFloorFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7228,12 +7784,12 @@ ExprFloorFunc(
static int
ExprIsqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
- ClientData ptr;
+ void *ptr;
int type;
double d;
Tcl_WideInt w;
@@ -7254,7 +7810,7 @@ ExprIsqrtFunc(
* Make sure that the arg is a number.
*/
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
@@ -7282,7 +7838,7 @@ ExprIsqrtFunc(
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
- if (big.sign) {
+ if (mp_isneg(&big)) {
mp_clear(&big);
goto negarg;
}
@@ -7310,10 +7866,16 @@ ExprIsqrtFunc(
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
} else {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
@@ -7328,7 +7890,7 @@ ExprIsqrtFunc(
static int
ExprSqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7344,21 +7906,32 @@ ExprSqrtFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
- if ((d >= 0.0) && TclIsInfinite(d)
+ if ((d >= 0.0) && isinf(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ mp_clear(&root);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
mp_clear(&root);
} else {
@@ -7369,7 +7942,7 @@ ExprSqrtFunc(
static int
ExprUnaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes one double argument and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7387,10 +7960,14 @@ ExprUnaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7406,12 +7983,12 @@ CheckDoubleResult(
double dResult)
{
#ifndef ACCEPT_NAN
- if (TclIsNaN(dResult)) {
+ if (isnan(dResult)) {
TclExprFloatError(interp, dResult);
return TCL_ERROR;
}
#endif
- if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
+ if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) {
/*
* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf
*/
@@ -7429,7 +8006,7 @@ CheckDoubleResult(
static int
ExprBinaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes two double arguments and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7447,10 +8024,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d1 = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d1 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7458,10 +8039,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
- d2 = objv[2]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d2 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7473,13 +8058,13 @@ ExprBinaryFunc(
static int
ExprAbsFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
- ClientData ptr;
+ void *ptr;
int type;
mp_int big;
@@ -7488,32 +8073,45 @@ ExprAbsFunc(
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
- if (type == TCL_NUMBER_LONG) {
- long l = *((const long *) ptr);
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
- if (l > (long)0) {
+ if (l > 0) {
goto unChanged;
- } else if (l == (long)0) {
- const char *string = objv[1]->bytes;
- if (string) {
- while (*string != '0') {
- if (*string == '-') {
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ } else if (l == 0) {
+ if (TclHasStringRep(objv[1])) {
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
+
+ while (numBytes) {
+ if (*bytes == '-') {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
- string++;
+ bytes++; numBytes--;
}
}
goto unChanged;
- } else if (l == LONG_MIN) {
- TclBNInitBignumFromLong(&big, l);
+ } else if (l == WIDE_MIN) {
+ if (sizeof(Tcl_WideInt) > sizeof(int64_t)) {
+ Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN;
+ if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1,
+ sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ } else if (mp_init_i64(&big, l) != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto tooLarge;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
@@ -7537,27 +8135,13 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
-
- if (w >= (Tcl_WideInt)0) {
- goto unChanged;
- }
- if (w == LLONG_MIN) {
- TclBNInitBignumFromWideInt(&big, w);
- goto tooLarge;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
- return TCL_OK;
- }
-#endif
-
if (type == TCL_NUMBER_BIG) {
- if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) {
+ if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
- (void)mp_neg(&big, &big);
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
@@ -7582,7 +8166,7 @@ ExprAbsFunc(
static int
ExprBoolFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7603,7 +8187,7 @@ ExprBoolFunc(
static int
ExprDoubleFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7617,7 +8201,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objv[1]->typePtr == &tclDoubleType) {
+ if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7629,8 +8213,8 @@ ExprDoubleFunc(
}
static int
-ExprEntierFunc(
- ClientData clientData, /* Ignored. */
+ExprIntFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7638,31 +8222,19 @@ ExprEntierFunc(
{
double d;
int type;
- ClientData ptr;
+ void *ptr;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
d = *((const double *) ptr);
- if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) {
- long result = (long) d;
-
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
- return TCL_OK;
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) {
- Tcl_WideInt result = (Tcl_WideInt) d;
-
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
- return TCL_OK;
-#endif
- } else {
+ if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7671,6 +8243,11 @@ ExprEntierFunc(
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
+ } else {
+ Tcl_WideInt result = (Tcl_WideInt) d;
+
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
}
}
@@ -7692,73 +8269,91 @@ ExprEntierFunc(
}
static int
-ExprIntFunc(
- ClientData clientData, /* Ignored. */
+ExprWideFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- long iResult;
- Tcl_Obj *objPtr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in long range.
- */
-
- mp_int big;
+ Tcl_WideInt wResult;
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &iResult);
- Tcl_DecrRefCount(objPtr);
+ if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
+ TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
+/*
+ * Common implmentation of max() and min().
+ */
static int
-ExprWideFunc(
- ClientData clientData, /* Ignored. */
+ExprMaxMinFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
- Tcl_Obj *const *objv) /* Actual parameter vector. */
+ Tcl_Obj *const *objv, /* Actual parameter vector. */
+ int op) /* Comparison direction */
{
- Tcl_WideInt wResult;
- Tcl_Obj *objPtr;
+ Tcl_Obj *res;
+ double d;
+ int type, i;
+ void *ptr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ if (objc < 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in wide int range.
- */
-
- mp_int big;
+ res = objv[1];
+ for (i = 1; i < objc; i++) {
+ if (Tcl_GetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ /*
+ * Get the error message for NaN.
+ */
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &wResult);
- Tcl_DecrRefCount(objPtr);
+ Tcl_GetDoubleFromObj(interp, objv[i], &d);
+ return TCL_ERROR;
+ }
+ if (TclCompareTwoNumbers(objv[i], res) == op) {
+ res = objv[i];
+ }
}
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
+
+ Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
+ExprMaxFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT);
+}
+
+static int
+ExprMinFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT);
+}
+
+static int
ExprRandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7851,14 +8446,14 @@ ExprRandFunc(
static int
ExprRoundFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
double d;
- ClientData ptr;
+ void *ptr;
int type;
if (objc != 2) {
@@ -7866,13 +8461,13 @@ ExprRoundFunc(
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
double fractPart, intPart;
- long max = LONG_MAX, min = LONG_MIN;
+ Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN;
fractPart = modf(*((const double *) ptr), &intPart);
if (fractPart <= -0.5) {
@@ -7882,27 +8477,31 @@ ExprRoundFunc(
}
if ((intPart >= (double)max) || (intPart <= (double)min)) {
mp_int big;
+ mp_err err = MP_OKAY;
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
/* Infinity */
return TCL_ERROR;
}
if (fractPart <= -0.5) {
- mp_sub_d(&big, 1, &big);
+ err = mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
- mp_add_d(&big, 1, &big);
+ err = mp_add_d(&big, 1, &big);
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
- long result = (long)intPart;
+ Tcl_WideInt result = (Tcl_WideInt)intPart;
if (fractPart <= -0.5) {
result--;
} else if (fractPart >= 0.5) {
result++;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
@@ -7926,14 +8525,14 @@ ExprRoundFunc(
static int
ExprSrandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
- long i = 0; /* Initialized to avoid compiler warning. */
+ Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
@@ -7944,20 +8543,8 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
- Tcl_Obj *objPtr;
- mp_int big;
-
- if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
- /* TODO: more ::errorInfo here? or in caller? */
- return TCL_ERROR;
- }
-
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &i);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -7966,8 +8553,7 @@ ExprSrandFunc(
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7FFFFFFF;
+ iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
@@ -7978,7 +8564,396 @@ ExprSrandFunc(
* will always succeed.
*/
- return ExprRandFunc(clientData, interp, 1, objv);
+ return ExprRandFunc(NULL, interp, 1, objv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Double Classification Functions --
+ *
+ * This page contains the functions that implement all of the built-in
+ * math functions for classifying IEEE doubles.
+ *
+ * These have to be a little bit careful while Tcl_GetDoubleFromObj()
+ * rejects NaN values, which these functions *explicitly* accept.
+ *
+ * Results:
+ * Each function returns TCL_OK if it succeeds and pushes an Tcl object
+ * holding the result. If it fails it returns TCL_ERROR and leaves an
+ * error message in the interpreter's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ *
+ * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course.
+ * But it does sometimes have _fpclass() which does almost the same job; if
+ * even that is absent, we grobble around directly in the platform's binary
+ * representation of double.
+ *
+ * The ClassifyDouble() function makes all that conform to a common API
+ * (effectively the C99 standard API renamed), and just delegates to the
+ * standard macro on platforms that do it correctly.
+ */
+
+static inline int
+ClassifyDouble(
+ double d)
+{
+#if TCL_FPCLASSIFY_MODE == 0
+ return fpclassify(d);
+#else /* TCL_FPCLASSIFY_MODE != 0 */
+ /*
+ * If we don't have fpclassify(), we also don't have the values it returns.
+ * Hence we define those here.
+ */
+#ifndef FP_NAN
+# define FP_NAN 1 /* Value is NaN */
+# define FP_INFINITE 2 /* Value is an infinity */
+# define FP_ZERO 3 /* Value is a zero */
+# define FP_NORMAL 4 /* Value is a normal float */
+# define FP_SUBNORMAL 5 /* Value has lost accuracy */
+#endif /* !FP_NAN */
+
+#if TCL_FPCLASSIFY_MODE == 3
+ return __builtin_fpclassify(
+ FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d);
+#elif TCL_FPCLASSIFY_MODE == 2
+ /*
+ * We assume this hack is only needed on little-endian systems.
+ * Specifically, x86 running Windows. It's fairly easy to enable for
+ * others if they need it (because their libc/libm is broken) but we'll
+ * jump that hurdle when requred. We can solve the word ordering then.
+ */
+
+ union {
+ double d; /* Interpret as double */
+ struct {
+ unsigned int low; /* Lower 32 bits */
+ unsigned int high; /* Upper 32 bits */
+ } w; /* Interpret as unsigned integer words */
+ } doubleMeaning; /* So we can look at the representation of a
+ * double directly. Platform (i.e., processor)
+ * specific; this is for x86 (and most other
+ * little-endian processors, but those are
+ * untested). */
+ unsigned int exponent, mantissaLow, mantissaHigh;
+ /* The pieces extracted from the double. */
+ int zeroMantissa; /* Was the mantissa zero? That's special. */
+
+ /*
+ * Shifts and masks to use with the doubleMeaning variable above.
+ */
+
+#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */
+#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */
+#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */
+
+ /*
+ * Extract the exponent (11 bits) and mantissa (52 bits). Note that we
+ * totally ignore the sign bit.
+ */
+
+ doubleMeaning.d = d;
+ exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK;
+ mantissaLow = doubleMeaning.w.low;
+ mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK;
+ zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0);
+
+ /*
+ * Look for the special cases of exponent.
+ */
+
+ switch (exponent) {
+ case 0:
+ /*
+ * When the exponent is all zeros, it's a ZERO or a SUBNORMAL.
+ */
+
+ return zeroMantissa ? FP_ZERO : FP_SUBNORMAL;
+ case EXPONENT_MASK:
+ /*
+ * When the exponent is all ones, it's an INF or a NAN.
+ */
+
+ return zeroMantissa ? FP_INFINITE : FP_NAN;
+ default:
+ /*
+ * Everything else is a NORMAL double precision float.
+ */
+
+ return FP_NORMAL;
+ }
+#elif TCL_FPCLASSIFY_MODE == 1
+ switch (_fpclass(d)) {
+ case _FPCLASS_NZ:
+ case _FPCLASS_PZ:
+ return FP_ZERO;
+ case _FPCLASS_NN:
+ case _FPCLASS_PN:
+ return FP_NORMAL;
+ case _FPCLASS_ND:
+ case _FPCLASS_PD:
+ return FP_SUBNORMAL;
+ case _FPCLASS_NINF:
+ case _FPCLASS_PINF:
+ return FP_INFINITE;
+ default:
+ Tcl_Panic("result of _fpclass() outside documented range!");
+ case _FPCLASS_QNAN:
+ case _FPCLASS_SNAN:
+ return FP_NAN;
+ }
+#else /* TCL_FPCLASSIFY_MODE not in (0..3) */
+#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
+#endif /* TCL_FPCLASSIFY_MODE */
+#endif /* !fpclassify */
+}
+
+static int
+ExprIsFiniteFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ type = ClassifyDouble(d);
+ result = (type != FP_INFINITE && type != FP_NAN);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsInfinityFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_INFINITE);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsNaNFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 1;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_NAN);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsNormalFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_NORMAL);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsSubnormalFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_SUBNORMAL);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsUnorderedFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 3) {
+ MathFuncWrongNumArgs(interp, 3, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ result = 1;
+ } else {
+ d = *((const double *) ptr);
+ result = (ClassifyDouble(d) == FP_NAN);
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ result |= 1;
+ } else {
+ d = *((const double *) ptr);
+ result |= (ClassifyDouble(d) == FP_NAN);
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+FloatClassifyObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ Tcl_Obj *objPtr;
+ void *ptr;
+ int type;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "floatValue");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ goto gotNaN;
+ } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (ClassifyDouble(d)) {
+ case FP_INFINITE:
+ TclNewLiteralStringObj(objPtr, "infinite");
+ break;
+ case FP_NAN:
+ gotNaN:
+ TclNewLiteralStringObj(objPtr, "nan");
+ break;
+ case FP_NORMAL:
+ TclNewLiteralStringObj(objPtr, "normal");
+ break;
+ case FP_SUBNORMAL:
+ TclNewLiteralStringObj(objPtr, "subnormal");
+ break;
+ case FP_ZERO:
+ TclNewLiteralStringObj(objPtr, "zero");
+ break;
+ default:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to classify number: %f", d));
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
}
/*
@@ -8005,7 +8980,7 @@ MathFuncWrongNumArgs(
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- const char *name = Tcl_GetString(objv[0]);
+ const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name+1) {
@@ -8040,8 +9015,8 @@ MathFuncWrongNumArgs(
static int
DTraceObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
@@ -8143,7 +9118,7 @@ TclDTraceInfo(
static int
DTraceCmdReturn(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8188,7 +9163,7 @@ int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
- ClientData clientData,
+ void *clientData,
int objc,
Tcl_Obj *const objv[])
{
@@ -8199,6 +9174,42 @@ Tcl_NRCallObjProc(
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
+int wrapperNRObjProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ clientData = info->clientData;
+ Tcl_ObjCmdProc2 *proc = info->proc;
+ ckfree(info);
+ return proc(clientData, interp, objc, objv);
+}
+
+int
+Tcl_NRCallObjProc2(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc,
+ void *clientData,
+ size_t objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc > INT_MAX) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?args?");
+ return TCL_ERROR;
+ }
+
+ NRE_callback *rootPtr = TOP_CB(interp);
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->clientData = clientData;
+ info->proc = objProc;
+
+ TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info,
+ INT2PTR(objc), objv);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -8227,6 +9238,50 @@ Tcl_NRCallObjProc(
*----------------------------------------------------------------------
*/
+static int cmdWrapperNreProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1;
+ }
+ return info->nreProc(info->clientData, interp, objc, objv);
+}
+
+Tcl_Command
+Tcl_NRCreateCommand2(
+ 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_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name, provides direct access for direct
+ * calls. */
+ Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->clientData = clientData;
+ info->nreProc = nreProc;
+ info->deleteProc = deleteProc;
+ info->deleteData = clientData;
+ return Tcl_NRCreateCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ (nreProc ? cmdWrapperNreProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -8240,14 +9295,15 @@ Tcl_NRCreateCommand(
* calls. */
Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *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);
+ Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8260,11 +9316,12 @@ TclNRCreateCommandInNs(
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc)
{
Command *cmdPtr = (Command *)
- TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+ TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8422,7 +9479,7 @@ TclSetTailcall(
int
TclNRTailcallObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8487,7 +9544,7 @@ TclNRTailcallObjCmd(
int
TclNRTailcallEval(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8497,7 +9554,7 @@ TclNRTailcallEval(
int objc;
Tcl_Obj **objv;
- TclListObjGetElements(interp, listPtr, &objc, &objv);
+ TclListObjGetElementsM(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
@@ -8526,8 +9583,8 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
@@ -8547,10 +9604,10 @@ void
Tcl_NRAddCallback(
Tcl_Interp *interp,
Tcl_NRPostProc *postProcPtr,
- ClientData data0,
- ClientData data1,
- ClientData data2,
- ClientData data3)
+ void *data0,
+ void *data1,
+ void *data2,
+ void *data3)
{
if (!(postProcPtr)) {
Tcl_Panic("Adding a callback without an objProc?!");
@@ -8584,7 +9641,7 @@ Tcl_NRAddCallback(
int
TclNRYieldObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8615,7 +9672,7 @@ TclNRYieldObjCmd(
int
TclNRYieldToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8659,19 +9716,21 @@ TclNRYieldToObjCmd(
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
+ /* Not calling Tcl_IncrRefCount(listPtr) here because listPtr is private */
TclSetTailcall(interp, listPtr);
+ corPtr->yieldPtr = listPtr;
iPtr->execEnvPtr = corPtr->eePtr;
- return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
+ return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv);
}
static int
RewindCoroutineCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- return Tcl_RestoreInterpState(interp, data[0]);
+ return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]);
}
static int
@@ -8694,7 +9753,7 @@ RewindCoroutine(
static void
DeleteCoroutine(
- ClientData clientData)
+ void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
@@ -8707,7 +9766,7 @@ DeleteCoroutine(
static int
NRCoroutineCallerCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8738,7 +9797,7 @@ NRCoroutineCallerCallback(
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* The command was deleted while it was running: wind down the
* execEnv, this will do the complete cleanup. RewindCoroutine will
@@ -8753,7 +9812,7 @@ NRCoroutineCallerCallback(
static int
NRCoroutineExitCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8818,14 +9877,11 @@ NRCoroutineExitCallback(
int
TclNRCoroutineActivateCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
- int type = PTR2INT(data[1]);
- int numLevels, unused;
- int *stackLevel = &unused;
if (!corPtr->stackLevel) {
/*
@@ -8842,8 +9898,8 @@ TclNRCoroutineActivateCallback(
* the interp's environment to make it suitable to run this coroutine.
*/
- corPtr->stackLevel = stackLevel;
- numLevels = corPtr->auxNumLevels;
+ corPtr->stackLevel = &corPtr;
+ int numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
SAVE_CONTEXT(corPtr->caller);
@@ -8856,7 +9912,23 @@ TclNRCoroutineActivateCallback(
* Coroutine is active: yield
*/
- if (corPtr->stackLevel != stackLevel) {
+ if (corPtr->stackLevel != &corPtr) {
+ NRE_callback *runPtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ if (corPtr->yieldPtr) {
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->data[1] == corPtr->yieldPtr) {
+ Tcl_DecrRefCount((Tcl_Obj *)runPtr->data[1]);
+ runPtr->data[1] = NULL;
+ corPtr->yieldPtr = NULL;
+ break;
+ }
+ }
+ }
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
@@ -8864,6 +9936,7 @@ TclNRCoroutineActivateCallback(
return TCL_ERROR;
}
+ void *type = data[1];
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
@@ -8872,9 +9945,10 @@ TclNRCoroutineActivateCallback(
Tcl_Panic("Yield received an option which is not implemented");
}
+ corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
- numLevels = iPtr->numLevels;
+ int numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
@@ -8897,9 +9971,9 @@ TclNRCoroutineActivateCallback(
static int
TclNREvalList(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
@@ -8909,7 +9983,7 @@ TclNREvalList(
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
- TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
@@ -8925,7 +9999,7 @@ TclNREvalList(
static int
CoroTypeObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8985,27 +10059,91 @@ CoroTypeObjCmd(
/*
*----------------------------------------------------------------------
*
- * NRCoroInjectObjCmd --
+ * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
*
- * Implementation of [::tcl::unsupported::inject] command.
+ * Implementation of [coroinject] and [coroprobe] commands.
*
*----------------------------------------------------------------------
*/
+static inline CoroutineData *
+GetCoroutineFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ const char *errMsg)
+{
+ /*
+ * How to get a coroutine from its handle.
+ */
+
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objPtr), NULL);
+ return NULL;
+ }
+ return (CoroutineData *)cmdPtr->objClientData;
+}
+
static int
-NRCoroInjectObjCmd(
- ClientData clientData,
+TclNRCoroInjectObjCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Command *cmdPtr;
CoroutineData *corPtr;
+
+ /*
+ * Usage more or less like tailcall:
+ * coroinject coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a suspended coroutine", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
+ 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.
+ */
+
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ return TCL_OK;
+}
+
+static int
+TclNRCoroProbeObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
/*
* Usage more or less like tailcall:
- * inject coroName cmd ?arg1 arg2 ...?
+ * coroprobe coroName cmd ?arg1 arg2 ...?
*/
if (objc < 3) {
@@ -9013,16 +10151,202 @@ NRCoroInjectObjCmd(
return TCL_ERROR;
}
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
- if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a probe command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can only inject a command into a coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
- TclGetString(objv[1]), NULL);
+ "can only inject a probe command into a suspended coroutine",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
- corPtr = cmdPtr->objClientData;
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed.
+ */
+
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ /*
+ * Now we immediately transfer control to the coroutine to run our probe.
+ * TRICKY STUFF copied from the [yield] implementation.
+ *
+ * Push the callback to restore the caller's context on yield back.
+ */
+
+ 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 = &corPtr;
+ int numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = iPtr->numLevels;
+
+ /*
+ * Do the actual stack swap.
+ */
+
+ SAVE_CONTEXT(corPtr->caller);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ RESTORE_CONTEXT(corPtr->running);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ iPtr->numLevels += numLevels;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InjectHandler, InjectHandlerPostProc --
+ *
+ * Part of the implementation of [coroinject] and [coroprobe]. These are
+ * run inside the context of the coroutine being injected/probed into.
+ *
+ * InjectHandler runs a script (possibly adding arguments) in the context
+ * of the coroutine. The script is specified as a one-shot list (with
+ * reference count equal to 1) in data[1]. This function also arranges
+ * for InjectHandlerPostProc to be the part that runs after the script
+ * completes.
+ *
+ * InjectHandlerPostProc cleans up after InjectHandler (deleting the
+ * list) and, for the [coroprobe] command *only*, yields back to the
+ * caller context (i.e., where [coroprobe] was run).
+ *s
+ *----------------------------------------------------------------------
+ */
+
+static int
+InjectHandler(
+ void *data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int) /*result*/)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
+ int nargs = PTR2INT(data[2]);
+ void *isProbe = data[3];
+ int objc;
+ Tcl_Obj **objv;
+
+ if (!isProbe) {
+ /*
+ * If this is [coroinject], add the extra arguments now.
+ */
+
+ if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yield", -1));
+ } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yieldto", -1));
+ } else {
+ /*
+ * I don't think this is reachable...
+ */
+
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj(nargs));
+ }
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
+ }
+
+ /*
+ * Call the user's script; we're in the right place.
+ */
+
+ Tcl_IncrRefCount(listPtr);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
+ INT2PTR(nargs), isProbe);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+static int
+InjectHandlerPostCall(
+ void *data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
+ int nargs = PTR2INT(data[2]);
+ void *isProbe = data[3];
+
+ /*
+ * Delete the command words for what we just executed.
+ */
+
+ Tcl_DecrRefCount(listPtr);
+
+ /*
+ * If we were doing a probe, splice ourselves back out of the stack
+ * cleanly here. General injection should instead just look after itself.
+ *
+ * Code from guts of [yield] implementation.
+ */
+
+ if (isProbe) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (injected coroutine probe command)");
+ }
+ corPtr->nargs = nargs;
+ corPtr->stackLevel = NULL;
+ int numLevels = iPtr->numLevels;
+ iPtr->numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRInjectObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::inject] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NRInjectObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ 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;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a command into a suspended coroutine", -1));
@@ -9045,7 +10369,7 @@ NRCoroInjectObjCmd(
int
TclNRInterpCoroutine(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9055,7 +10379,7 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
- Tcl_GetString(objv[0])));
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
@@ -9076,7 +10400,7 @@ TclNRInterpCoroutine(
}
break;
default:
- if (corPtr->nargs != objc-1) {
+ if (corPtr->nargs + 1 != objc) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("wrong coro nargs; how did we get here? "
"not implemented!", -1));
@@ -9109,7 +10433,7 @@ TclNRInterpCoroutine(
int
TclNRCoroutineObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9197,6 +10521,7 @@ TclNRCoroutineObjCmd(
corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
corPtr->stackLevel = NULL;
corPtr->auxNumLevels = 0;
+ corPtr->yieldPtr = NULL;
/*
* Create the coro's execEnv, switch to it to push the exit and coro
@@ -9242,7 +10567,7 @@ TclNRCoroutineObjCmd(
int
TclInfoCoroutineCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -9254,7 +10579,7 @@ TclInfoCoroutineCmd(
return TCL_ERROR;
}
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 703c35b..b744203 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -2,19 +2,20 @@
* tclBinary.c --
*
* This file contains the implementation of the "binary" Tcl built-in
- * command and the Tcl binary data object.
+ * command and the Tcl value internal representation for binary data.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* 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 "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
+#include <assert.h>
/*
* The following constants are used by GetFormatSpec to indicate various
@@ -56,9 +57,12 @@
static void DupByteArrayInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
+static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr);
static int FormatNumber(Tcl_Interp *interp, int type,
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
+static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(const char **formatPtr, char *cmdPtr,
int *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
@@ -139,35 +143,80 @@ static const EnsembleImplMap decodeMap[] = {
};
/*
- * The following object type represents an array of bytes. An array of bytes
- * is not equivalent to an internationalized string. Conceptually, a string is
- * an array of 16-bit quantities organized as a sequence of properly formed
- * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
- * Accessor functions are provided to convert a ByteArray to a String or a
- * String to a ByteArray. Two or more consecutive bytes in an array of bytes
- * may look like a single UTF-8 character if the array is casually treated as
- * a string. But obtaining the String from a ByteArray is guaranteed to
- * produced properly formed UTF-8 sequences so that there is a one-to-one map
- * between bytes and characters.
- *
- * Converting a ByteArray to a String proceeds by casting each byte in the
- * array to a 16-bit quantity, treating that number as a Unicode character,
- * and storing the UTF-8 version of that Unicode character in the String. For
- * ByteArrays consisting entirely of values 1..127, the corresponding String
- * representation is the same as the ByteArray representation.
- *
- * Converting a String to a ByteArray proceeds by getting the Unicode
- * representation of each character in the String, casting it to a byte by
- * truncating the upper 8 bits, and then storing the byte in the ByteArray.
- * Converting from ByteArray to String and back to ByteArray is not lossy, but
- * converting an arbitrary String to a ByteArray may be.
+ * The following object types represent an array of bytes. The intent is to
+ * allow arbitrary binary data to pass through Tcl as a Tcl value without loss
+ * or damage. Such values are useful for things like encoded strings or Tk
+ * images to name just two.
+ *
+ * It's strange to have two Tcl_ObjTypes in place for this task when one would
+ * do, so a bit of detail and history will aid understanding.
+ *
+ * A bytearray is an ordered sequence of bytes. Each byte is an integer value
+ * in the range [0-255]. To be a Tcl value type, we need a way to encode each
+ * value in the value set as a Tcl string. A simple encoding is to
+ * represent each byte value as the same codepoint value. A bytearray of N
+ * bytes is encoded into a Tcl string of N characters where the codepoint of
+ * each character is the value of corresponding byte. This approach creates a
+ * one-to-one map between all bytearray values and a subset of Tcl string
+ * values.
+ *
+ * When converting a Tcl string value to the bytearray internal rep, the
+ * question arises what to do with strings outside that subset? That is,
+ * those Tcl strings containing at least one codepoint greater than 255? The
+ * obviously correct answer is to raise an error! That string value does not
+ * represent any valid bytearray value.
+ *
+ * Unfortunately this was not the path taken by the authors of the original
+ * tclByteArrayType. They chose to accept all Tcl string values as acceptable
+ * string encodings of the bytearray values that result from masking away the
+ * high bits of any codepoint value at all. This meant that every bytearray
+ * value had multiple accepted string representations.
+ *
+ * The implications of this choice are truly ugly, and motivated the proposal
+ * of TIP 568 to migrate away from it and to the more sensible design where
+ * each bytearray value has only one string representation. Full details are
+ * recorded in that TIP for those who seek them.
+ *
+ * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation
+ * of bytearrays. Any Tcl value with the type properByteArrayType can have
+ * its bytearray value fetched and used with confidence that acting on that
+ * value is equivalent to acting on the true Tcl string value. This still
+ * implies a side testing burden -- past mistakes will not let us avoid that
+ * immediately, but it is at least a conventional test of type, and can be
+ * implemented entirely by examining the objPtr fields, with no need to query
+ * the internalrep, as a canonical flag would require. This benefit is made
+ * available to extensions through the public routine Tcl_GetBytesFromObj(),
+ * first available in Tcl 8.7.
+ *
+ * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength()
+ * must continue to follow their documented behavior through the 8.* series of
+ * releases. To support that legacy operation, we need a mechanism to retain
+ * compatibility with the deployed callers of the broken interface. That's
+ * what the retained "tclByteArrayType" provides. In those unusual
+ * circumstances where we convert an invalid bytearray value to a bytearray
+ * type, it is to this legacy type. Essentially any time this legacy type
+ * shows up, it's a signal of a bug being ignored.
+ *
+ * In Tcl 9, the incompatibility in the behavior of these public routines
+ * has been approved, and the legacy internal rep is no longer retained.
+ * The internal changes seen below are the limit of what can be done
+ * in a Tcl 8.* release. They provide a great expansion of the histories
+ * over which bytearray values can be useful.
*/
+static const Tcl_ObjType properByteArrayType = {
+ "bytearray",
+ FreeProperByteArrayInternalRep,
+ DupProperByteArrayInternalRep,
+ UpdateStringOfByteArray,
+ NULL
+};
+
const Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
- UpdateStringOfByteArray,
+ NULL,
SetByteArrayFromAny
};
@@ -179,23 +228,31 @@ const Tcl_ObjType tclByteArrayType = {
*/
typedef struct ByteArray {
+ unsigned int bad; /* Index of first character that is a nonbyte.
+ * If all characters are bytes, bad = used. */
unsigned int used; /* The number of bytes used in the byte
- * array. */
- unsigned int allocated; /* The number of bytes allocated for storage
- * of the following "bytes" field. */
+ * array. Must be <= allocated. The bytes
+ * used to store the value are indexed from
+ * 0 to used-1. */
+ unsigned int allocated; /* The number of bytes of space allocated. */
unsigned char bytes[TCLFLEXARRAY];
/* The array of bytes. The actual size of this
- * field depends on the 'allocated' field
+ * field is stored in the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
- (((unsigned)TclOffset(ByteArray, bytes) + (len)))
-#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
-#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
-
+ (offsetof(ByteArray, bytes) + (len))
+#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
+#define SET_BYTEARRAY(irPtr, baPtr) \
+ (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr)
+
+int
+TclIsPureByteArray(
+ Tcl_Obj * objPtr)
+{
+ return TclHasInternalRep(objPtr, &properByteArrayType);
+}
/*
*----------------------------------------------------------------------
@@ -206,7 +263,7 @@ typedef struct ByteArray {
* from the given array of bytes.
*
* Results:
- * The newly create object is returned. This object will have no initial
+ * The newly created object is returned. This object has no initial
* string representation. The returned object has a ref count of 0.
*
* Side effects:
@@ -221,16 +278,16 @@ 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. */
+ int numBytes) /* Number of bytes in the array,
+ * must be >= 0. */
{
#ifdef TCL_MEM_DEBUG
- return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
+ return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetByteArrayObj(objPtr, bytes, length);
+ Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
return objPtr;
#endif /* TCL_MEM_DEBUG */
}
@@ -251,7 +308,7 @@ Tcl_NewByteArrayObj(
* result of calling Tcl_NewByteArrayObj.
*
* Results:
- * The newly create object is returned. This object will have no initial
+ * The newly created object is returned. This object has no initial
* string representation. The returned object has a ref count of 0.
*
* Side effects:
@@ -260,27 +317,37 @@ Tcl_NewByteArrayObj(
*----------------------------------------------------------------------
*/
+#ifdef 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. */
+ int numBytes, /* Number of bytes in the array,
+ * 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. */
{
-#ifdef TCL_MEM_DEBUG
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetByteArrayObj(objPtr, bytes, length);
+ Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
return objPtr;
+}
#else /* if not TCL_MEM_DEBUG */
- return Tcl_NewByteArrayObj(bytes, length);
-#endif /* TCL_MEM_DEBUG */
+Tcl_Obj *
+Tcl_DbNewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int numBytes, /* Number of bytes in the array,
+ * must be >= 0. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ return Tcl_NewByteArrayObj(bytes, numBytes);
}
+#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
@@ -304,36 +371,131 @@ 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.
- * May be NULL even if length > 0. */
- int length) /* Length of the array of bytes, which must
- * be >= 0. */
+ * May be NULL even if numBytes > 0. */
+ int numBytes) /* Number of bytes in the array,
+ * must be >= 0. */
{
ByteArray *byteArrayPtr;
+ Tcl_ObjInternalRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
- TclFreeIntRep(objPtr);
TclInvalidateStringRep(objPtr);
- if (length < 0) {
- length = 0;
+ assert(numBytes >= 0);
+ byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes));
+ byteArrayPtr->bad = numBytes;
+ byteArrayPtr->used = numBytes;
+ byteArrayPtr->allocated = numBytes;
+
+ if ((bytes != NULL) && (numBytes > 0)) {
+ memcpy(byteArrayPtr->bytes, bytes, numBytes);
}
- byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
- byteArrayPtr->used = length;
- byteArrayPtr->allocated = length;
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+
+ Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBytesFromObj/TclGetBytesFromObj --
+ *
+ * Attempt to extract the value from objPtr in the representation
+ * of a byte sequence. On success return the extracted byte sequence.
+ * On failure, return NULL and record error message and code in
+ * interp (if not NULL).
+ *
+ * Results:
+ * NULL or pointer to array of bytes representing the ByteArray object.
+ * Writes number of bytes in array to *numBytesPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned char *
+TclGetBytesFromObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj *objPtr, /* Value to extract from */
+ int *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
+{
+ ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ if (interp) {
+ const char *nonbyte;
+ int ucs4;
+
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ baPtr = GET_BYTEARRAY(irPtr);
+ nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
+ TclUtfToUCS4(nonbyte, &ucs4);
- if ((bytes != NULL) && (length > 0)) {
- memcpy(byteArrayPtr->bytes, bytes, length);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected byte sequence but character %d "
+ "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
+ }
+ return NULL;
+ }
+ }
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
}
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ return baPtr->bytes;
+}
+#undef Tcl_GetBytesFromObj
+unsigned char *
+Tcl_GetBytesFromObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj *objPtr, /* Value to extract from */
+ size_t *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
+{
+ ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ if (interp) {
+ const char *nonbyte;
+ int ucs4;
+
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ baPtr = GET_BYTEARRAY(irPtr);
+ nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
+ TclUtfToUCS4(nonbyte, &ucs4);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected byte sequence but character %d "
+ "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
+ }
+ return NULL;
+ }
+ }
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
+ }
+ return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_GetByteArrayFromObj --
+ * Tcl_GetByteArrayFromObj/TclGetByteArrayFromObj --
*
* Attempt to get the array of bytes from the Tcl object. If the object
* is not already a ByteArray object, an attempt will be made to convert
@@ -348,24 +510,57 @@ Tcl_SetByteArrayObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetByteArrayFromObj
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
- int *lengthPtr) /* If non-NULL, filled with length of the
- * array of bytes in the ByteArray object. */
+ int *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
{
ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr;
+ unsigned char *result = TclGetBytesFromObj(NULL, objPtr, numBytesPtr);
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+ if (result) {
+ return result;
}
- baPtr = GET_BYTEARRAY(objPtr);
- if (lengthPtr != NULL) {
- *lengthPtr = baPtr->used;
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ assert(irPtr != NULL);
+
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
}
return (unsigned char *) baPtr->bytes;
}
+
+unsigned char *
+TclGetByteArrayFromObj(
+ Tcl_Obj *objPtr, /* The ByteArray object. */
+ size_t *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
+{
+ ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr;
+ unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr);
+
+ if (result) {
+ return result;
+ }
+
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ assert(irPtr != NULL);
+
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ /* Make sure we return a value between 0 and UINT_MAX-1, or (size_t)-1 */
+ *numBytesPtr = ((size_t)(unsigned int)(baPtr->used + 1)) - 1;
+ }
+ return baPtr->bytes;
+}
/*
*----------------------------------------------------------------------
@@ -392,27 +587,44 @@ Tcl_GetByteArrayFromObj(
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
- int length) /* New length for internal byte array. */
+ int numBytes) /* Number of bytes in resized array */
{
ByteArray *byteArrayPtr;
+ unsigned newLength;
+ Tcl_ObjInternalRep *irPtr;
+
+ assert(numBytes >= 0);
+ newLength = (unsigned int)numBytes;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
- }
- if (length < 0) {
- length = 0;
+
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- if ((unsigned int)length > byteArrayPtr->allocated) {
- byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
- byteArrayPtr->allocated = length;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+
+ /* Note that during truncation, the implementation does not free
+ * memory that is no longer needed. */
+
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
+ if (newLength > byteArrayPtr->allocated) {
+ byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength));
+ byteArrayPtr->allocated = newLength;
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
- byteArrayPtr->used = length;
+ objPtr->typePtr = &properByteArrayType;
+ byteArrayPtr->bad = newLength;
+ byteArrayPtr->used = newLength;
return byteArrayPtr->bytes;
}
@@ -434,32 +646,51 @@ Tcl_SetByteArrayLength(
static int
SetByteArrayFromAny(
- Tcl_Interp *interp, /* Not used. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- int length;
+ int length, bad;
const char *src, *srcEnd;
unsigned char *dst;
- ByteArray *byteArrayPtr;
Tcl_UniChar ch = 0;
+ ByteArray *byteArrayPtr;
+ Tcl_ObjInternalRep ir;
+
+ if (TclHasInternalRep(objPtr, &properByteArrayType)) {
+ return TCL_OK;
+ }
+ if (TclHasInternalRep(objPtr, &tclByteArrayType)) {
+ return TCL_OK;
+ }
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(objPtr, &length);
- srcEnd = src + length;
+ src = TclGetStringFromObj(objPtr, &length);
+ bad = length;
+ srcEnd = src + length;
- byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
- for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
- src += TclUtfToUniChar(src, &ch);
- *dst++ = UCHAR(ch);
+ /* Note the allocation is over-sized, possibly by a factor of four,
+ * or even a factor of two with a proper byte array value. */
+
+ byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
+ src += TclUtfToUniChar(src, &ch);
+ if ((bad == length) && (ch > 255)) {
+ bad = dst - byteArrayPtr->bytes;
}
+ *dst++ = UCHAR(ch);
+ }
- byteArrayPtr->used = dst - byteArrayPtr->bytes;
- byteArrayPtr->allocated = length;
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+ byteArrayPtr->allocated = length;
+ byteArrayPtr->used = dst - byteArrayPtr->bytes;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ if (bad == length) {
+ byteArrayPtr->bad = byteArrayPtr->used;
+ Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
+ } else {
+ byteArrayPtr->bad = bad;
+ Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir);
}
+
return TCL_OK;
}
@@ -484,8 +715,14 @@ static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree(GET_BYTEARRAY(objPtr));
- objPtr->typePtr = NULL;
+ ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType)));
+}
+
+static void
+FreeProperByteArrayInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
+{
+ ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType)));
}
/*
@@ -512,17 +749,41 @@ DupByteArrayInternalRep(
{
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjInternalRep ir;
- srcArrayPtr = GET_BYTEARRAY(srcPtr);
+ srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
- SET_BYTEARRAY(copyPtr, copyArrayPtr);
- copyPtr->typePtr = &tclByteArrayType;
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir);
+}
+
+static void
+DupProperByteArrayInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ unsigned int length;
+ ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjInternalRep ir;
+
+ srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType));
+ length = srcArrayPtr->used;
+
+ copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->bad = length;
+ copyArrayPtr->used = length;
+ copyArrayPtr->allocated = length;
+ memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
+
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreInternalRep(copyPtr, &properByteArrayType, &ir);
}
/*
@@ -530,9 +791,7 @@ DupByteArrayInternalRep(
*
* UpdateStringOfByteArray --
*
- * Update the string representation for a ByteArray data object. Note:
- * This procedure does not invalidate an existing old string rep so
- * storage will be lost if this has not already been done.
+ * Update the string representation for a ByteArray data object.
*
* Results:
* None.
@@ -541,9 +800,6 @@ DupByteArrayInternalRep(
* The object's string is set to a valid string that results from the
* ByteArray-to-string conversion.
*
- * The object becomes a string object -- the internal rep is discarded
- * and the typePtr becomes NULL.
- *
*----------------------------------------------------------------------
*/
@@ -552,20 +808,16 @@ UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
- unsigned int i, length, size;
- unsigned char *src;
- char *dst;
- ByteArray *byteArrayPtr;
-
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- src = byteArrayPtr->bytes;
- length = byteArrayPtr->used;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
+ unsigned char *src = byteArrayPtr->bytes;
+ unsigned int i, length = byteArrayPtr->used;
+ unsigned int size = length;
/*
* How much space will string rep need?
*/
- size = length;
for (i = 0; i < length && size <= INT_MAX; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
@@ -575,18 +827,17 @@ UpdateStringOfByteArray(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- dst = (char *)ckalloc(size + 1U);
- objPtr->bytes = dst;
- objPtr->length = size;
-
if (size == length) {
- memcpy(dst, src, size);
- dst[size] = '\0';
+ char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);
+
+ TclOOM(dst, size);
} else {
+ char *dst = Tcl_InitStringRep(objPtr, NULL, size);
+
+ TclOOM(dst, size);
for (i = 0; i < length; i++) {
dst += Tcl_UniCharToUtf(src[i], dst);
}
- *dst = '\0';
}
}
@@ -616,7 +867,8 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
- unsigned int needed;
+ unsigned int length, needed;
+ Tcl_ObjInternalRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -632,16 +884,27 @@ TclAppendBytesToByteArray(
return;
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ length = (unsigned int) len;
+
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
- if ((unsigned int)len > INT_MAX - byteArrayPtr->used) {
+ if (length > INT_MAX - byteArrayPtr->used) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- needed = byteArrayPtr->used + len;
+ needed = byteArrayPtr->used + length;
/*
* If we need to, resize the allocated space in the byte array.
*/
@@ -664,7 +927,7 @@ TclAppendBytesToByteArray(
*/
unsigned int limit = INT_MAX - needed;
- unsigned int extra = len + TCL_MIN_GROWTH;
+ unsigned int extra = length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
@@ -680,14 +943,15 @@ TclAppendBytesToByteArray(
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
- memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
+ memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length);
}
- byteArrayPtr->used += len;
+ byteArrayPtr->used += length;
TclInvalidateStringRep(objPtr);
+ objPtr->typePtr = &properByteArrayType;
}
/*
@@ -737,7 +1001,7 @@ TclInitBinaryCmd(
static int
BinaryFormatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -861,11 +1125,10 @@ BinaryFormatCmd(
* The macro evals its args more than once: avoid arg++
*/
- if (TclListObjGetElements(interp, objv[arg], &listc,
- &listv) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[arg], &listc
+ ) != TCL_OK) {
return TCL_ERROR;
}
- arg++;
if (count == BINARY_ALL) {
count = listc;
@@ -875,6 +1138,11 @@ BinaryFormatCmd(
-1));
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, objv[arg], &listc,
+ &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
}
offset += count*size;
break;
@@ -1143,7 +1411,7 @@ BinaryFormatCmd(
listc = 1;
count = 1;
} else {
- TclListObjGetElements(interp, objv[arg], &listc, &listv);
+ TclListObjGetElementsM(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
@@ -1209,11 +1477,11 @@ BinaryFormatCmd(
badField:
{
- int ch;
- char buf[8] = "";
+ Tcl_UniChar ch = 0;
+ char buf[5] = "";
- TclUtfToUCS4(errorString, &ch);
- buf[TclUCS4ToUtf(ch, buf)] = '\0';
+ TclUtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
@@ -1242,7 +1510,7 @@ BinaryFormatCmd(
static int
BinaryScanCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1260,9 +1528,8 @@ BinaryScanCmd(
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
- int offset, size, length;
+ int offset, size, length, i;
- int i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
@@ -1286,7 +1553,8 @@ BinaryScanCmd(
}
switch (cmd) {
case 'a':
- case 'A': {
+ case 'A':
+ case 'C': {
unsigned char *src;
if (arg >= objc) {
@@ -1308,10 +1576,18 @@ BinaryScanCmd(
size = count;
/*
- * Trim trailing nulls and spaces, if necessary.
+ * Apply C string semantics or trim trailing
+ * nulls and spaces, if necessary.
*/
- if (cmd == 'A') {
+ if (cmd == 'C') {
+ for (i = 0; i < size; i++) {
+ if (src[i] == '\0') {
+ size = i;
+ break;
+ }
+ }
+ } else if (cmd == 'A') {
while (size > 0) {
if (src[size - 1] != '\0' && src[size - 1] != ' ') {
break;
@@ -1564,7 +1840,7 @@ BinaryScanCmd(
*/
done:
- Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3));
DeleteScanNumberCache(numberCachePtr);
return TCL_OK;
@@ -1579,11 +1855,11 @@ BinaryScanCmd(
badField:
{
- int ch;
- char buf[8] = "";
+ Tcl_UniChar ch = 0;
+ char buf[5] = "";
- TclUtfToUCS4(errorString, &ch);
- buf[TclUCS4ToUtf(ch, buf)] = '\0';
+ TclUtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
@@ -1852,7 +2128,7 @@ CopyNumber(
*
* FormatNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to format a number into a
+ * This routine is called by BinaryFormatCmd to format a number into a
* location pointed at by cursor.
*
* Results:
@@ -1872,7 +2148,6 @@ FormatNumber(
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
- long value;
double dvalue;
Tcl_WideInt wvalue;
float fvalue;
@@ -1888,10 +2163,11 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
@@ -1907,10 +2183,12 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
+
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
/*
@@ -1920,7 +2198,11 @@ FormatNumber(
*/
if (fabs(dvalue) > (double) FLT_MAX) {
+ if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) {
+ fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99
+ } else {
fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ }
} else {
fvalue = (float) dvalue;
}
@@ -1934,7 +2216,7 @@ FormatNumber(
case 'w':
case 'W':
case 'm':
- if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -1964,19 +2246,19 @@ FormatNumber(
case 'i':
case 'I':
case 'n':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 24);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -1986,15 +2268,15 @@ FormatNumber(
case 's':
case 'S':
case 't':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2002,10 +2284,10 @@ FormatNumber(
* 8-bit integer values.
*/
case 'c':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue);
return TCL_OK;
default:
@@ -2019,7 +2301,7 @@ FormatNumber(
*
* ScanNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to scan a number out of a
+ * This routine is called by BinaryScanCmd to scan a number out of a
* buffer.
*
* Results:
@@ -2131,7 +2413,7 @@ ScanNumber(
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
@@ -2142,8 +2424,9 @@ ScanNumber(
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
- Tcl_Obj *objPtr = Tcl_NewLongObj(value);
+ Tcl_Obj *objPtr;
+ TclNewIntObj(objPtr, value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
@@ -2160,7 +2443,7 @@ ScanNumber(
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
}
/*
@@ -2194,8 +2477,9 @@ ScanNumber(
Tcl_Obj *bigObj = NULL;
mp_int big;
- TclBNInitBignumFromWideUInt(&big, uwvalue);
- bigObj = Tcl_NewBignumObj(&big);
+ if (mp_init_u64(&big, uwvalue) == MP_OKAY) {
+ bigObj = Tcl_NewBignumObj(&big);
+ }
return bigObj;
}
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
@@ -2307,7 +2591,7 @@ DeleteScanNumberCache(
static int
BinaryEncodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2351,7 +2635,7 @@ BinaryEncodeHex(
static int
BinaryDecodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2359,8 +2643,8 @@ BinaryDecodeHex(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
- int i, index, value, size, pure, count = 0, cut = 0, strict = 0;
- Tcl_UniChar ch = 0;
+ int i, index, value, size, pure = 1, count = 0, cut = 0, strict = 0;
+ int ucs4;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2381,9 +2665,12 @@ BinaryDecodeHex(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -2396,7 +2683,7 @@ BinaryDecodeHex(
}
c = *data++;
- if (!isxdigit((int) c)) {
+ if (!isxdigit(UCHAR(c))) {
if (strict || !TclIsSpaceProc(c)) {
goto badChar;
}
@@ -2429,14 +2716,14 @@ BinaryDecodeHex(
badChar:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid hexadecimal digit \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
+ "invalid hexadecimal digit \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
return TCL_ERROR;
}
@@ -2472,7 +2759,7 @@ BinaryDecodeHex(
static int
BinaryEncode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2510,12 +2797,11 @@ BinaryEncode64(
}
break;
case OPT_WRAPCHAR:
- purewrap = TclIsPureByteArray(objv[i + 1]);
- if (purewrap) {
- wrapchar = (const char *) Tcl_GetByteArrayFromObj(
- objv[i + 1], &wrapcharlen);
- } else {
- wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen);
+ wrapchar = (const char *)TclGetBytesFromObj(NULL,
+ objv[i + 1], &wrapcharlen);
+ if (wrapchar == NULL) {
+ purewrap = 0;
+ wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
@@ -2595,7 +2881,7 @@ BinaryEncode64(
static int
BinaryEncodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2744,7 +3030,7 @@ BinaryEncodeUu(
static int
BinaryDecodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2752,9 +3038,9 @@ BinaryDecodeUu(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
- int i, index, size, pure, count = 0, strict = 0, lineLen;
+ int i, index, size, pure = 1, count = 0, strict = 0, lineLen;
unsigned char c;
- Tcl_UniChar ch = 0;
+ int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2775,9 +3061,12 @@ BinaryDecodeUu(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -2884,13 +3173,13 @@ BinaryDecodeUu(
badUu:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid uuencode character \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
+ "invalid uuencode character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
@@ -2914,7 +3203,7 @@ BinaryDecodeUu(
static int
BinaryDecode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2923,9 +3212,9 @@ BinaryDecode64(
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
- int pure, strict = 0;
+ int pure = 1, strict = 0;
int i, index, size, cut = 0, count = 0;
- Tcl_UniChar ch = 0;
+ int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2946,9 +3235,12 @@ BinaryDecode64(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -3050,19 +3342,19 @@ BinaryDecode64(
bad64:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid base64 character \"%c\" at position %d", ch,
- (int) (data - datastart - 1)));
+ "invalid base64 character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 20285eb..0ad2c46 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -5,9 +5,9 @@
* problems involving overwritten, double freeing memory and loss of
* memory.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -33,15 +33,15 @@
* "memory tag" command is invoked, to hold the current tag.
*/
-typedef struct MemTag {
- int refCount; /* Number of mem_headers referencing this
+typedef struct {
+ size_t refCount; /* Number of mem_headers referencing this
* tag. */
- char string[1]; /* Actual size of string will be as large as
+ char string[TCLFLEXARRAY]; /* 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) ((TclOffset(MemTag, string) + 1U) + (bytesInString)))
+#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1U) + (bytesInString))
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,26 +52,26 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* to help detect chunk under-runs.
*/
-#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
+#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8)
struct mem_header {
struct mem_header *flink;
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
const char *file;
- long length;
+ size_t length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
/* Aligns body on 8-byte boundary, plus
* provides at least 8 additional guard bytes
* to detect underruns. */
- char body[1]; /* First byte of client's space. Actual size
+ char body[TCLFLEXARRAY]; /* First byte of client's space. Actual size
* of this field will be larger than one. */
};
static struct mem_header *allocHead = NULL; /* List of allocated structures */
-#define GUARD_VALUE 0141
+#define GUARD_VALUE 0x61
/*
* The following macro determines the amount of guard space *above* each chunk
@@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */
#define BODY_OFFSET \
((size_t) (&((struct mem_header *) 0)->body))
-static int total_mallocs = 0;
-static int total_frees = 0;
+static size_t total_mallocs = 0;
+static size_t total_frees = 0;
static size_t current_bytes_malloced = 0;
static size_t maximum_bytes_malloced = 0;
-static int current_malloc_packets = 0;
-static int maximum_malloc_packets = 0;
-static int break_on_malloc = 0;
-static int trace_on_at_malloc = 0;
+static size_t current_malloc_packets = 0;
+static size_t maximum_malloc_packets = 0;
+static size_t break_on_malloc = 0;
+static size_t trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
@@ -128,24 +128,13 @@ static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
- * Prototypes for procedures defined in this file:
- */
-
-static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
-static int MemoryCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
-static void ValidateMemory(struct mem_header *memHeaderP,
- const char *file, int line, int nukeGuards);
-
-/*
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
*
* Initialize the locks used by the allocator. This is only appropriate
* to call in a single threaded environment, such as during
- * TclInitSubsystems.
+ * Tcl_InitSubsystems.
*
*----------------------------------------------------------------------
*/
@@ -156,7 +145,7 @@ TclInitDbCkalloc(void)
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/* Silence compiler warning */
(void)ckallocMutexPtr;
#endif
@@ -175,7 +164,7 @@ TclInitDbCkalloc(void)
int
TclDumpMemoryInfo(
- ClientData clientData,
+ void *clientData,
int flags)
{
char buf[1024];
@@ -184,18 +173,18 @@ TclDumpMemoryInfo(
return 0;
}
sprintf(buf,
- "total mallocs %10d\n"
- "total frees %10d\n"
- "current packets allocated %10d\n"
- "current bytes allocated %10lu\n"
- "maximum packets allocated %10d\n"
- "maximum bytes allocated %10lu\n",
+ "total mallocs %10" TCL_Z_MODIFIER "u\n"
+ "total frees %10" TCL_Z_MODIFIER "u\n"
+ "current packets allocated %10" TCL_Z_MODIFIER "u\n"
+ "current bytes allocated %10" TCL_Z_MODIFIER "u\n"
+ "maximum packets allocated %10" TCL_Z_MODIFIER "u\n"
+ "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n",
total_mallocs,
total_frees,
current_malloc_packets,
- (unsigned long)current_bytes_malloced,
+ current_bytes_malloced,
maximum_malloc_packets,
- (unsigned long)maximum_bytes_malloced);
+ maximum_bytes_malloced);
if (flags == 0) {
fprintf((FILE *)clientData, "%s", buf);
} else {
@@ -245,16 +234,16 @@ ValidateMemory(
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
- fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte,
+ fprintf(stderr, "low guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
- TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "low guard failed at %lx, %s %d\n",
- (unsigned long)(size_t)memHeaderP->body, file, line);
+ TclDumpMemoryInfo(stderr, 0);
+ fprintf(stderr, "low guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -266,17 +255,17 @@ ValidateMemory(
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
- fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", (int)idx, byte,
+ fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
- TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "high guard failed at %lx, %s %d\n",
- (unsigned long)(size_t)memHeaderP->body, file, line);
+ TclDumpMemoryInfo(stderr, 0);
+ fprintf(stderr, "high guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
@@ -359,9 +348,8 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
- fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
- (unsigned long)(size_t)address,
- (unsigned long)(size_t)address + memScanP->length - 1,
+ fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s",
+ address, address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
@@ -380,7 +368,7 @@ Tcl_DumpActiveMemory(
* Tcl_DbCkalloc - debugging ckalloc
*
* Allocate the requested amount of space plus some extra for guard bands
- * at both ends of the request, plus a size, panicing if there isn't
+ * at both ends of the request, plus a size, panicking if there isn't
* enough space, then write in the guard bands and return the address of
* the space in the middle that the user asked for.
*
@@ -405,13 +393,13 @@ Tcl_DbCkalloc(
}
/* Don't let size argument to TclpAlloc overflow */
- if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
+ if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) {
result = (struct mem_header *) TclpAlloc(size +
- sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
- TclDumpMemoryInfo((ClientData) stderr, 0);
+ TclDumpMemoryInfo(stderr, 0);
Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
@@ -423,7 +411,7 @@ Tcl_DbCkalloc(
if (init_malloced_bodies) {
memset(result, GUARD_VALUE,
- size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size);
} else {
memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
@@ -450,7 +438,7 @@ Tcl_DbCkalloc(
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
- fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -458,14 +446,14 @@ Tcl_DbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (unsigned long)(size_t)result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
+ Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
}
current_malloc_packets++;
@@ -495,13 +483,13 @@ Tcl_AttemptDbCkalloc(
}
/* Don't let size argument to TclpAlloc overflow */
- if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
+ if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) {
result = (struct mem_header *) TclpAlloc(size +
- sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
- TclDumpMemoryInfo((ClientData) stderr, 0);
+ TclDumpMemoryInfo(stderr, 0);
return NULL;
}
@@ -512,7 +500,7 @@ Tcl_AttemptDbCkalloc(
*/
if (init_malloced_bodies) {
memset(result, GUARD_VALUE,
- size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size);
} else {
memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
@@ -539,7 +527,7 @@ Tcl_AttemptDbCkalloc(
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
- fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -547,14 +535,14 @@ Tcl_AttemptDbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (unsigned long)(size_t)result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
+ Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
}
current_malloc_packets++;
@@ -612,8 +600,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %lx %ld %s %d\n",
- (unsigned long)(size_t)memp->body, memp->length, file, line);
+ fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n",
+ memp->body, memp->length, file, line);
}
if (validate_memory) {
@@ -631,9 +619,8 @@ Tcl_DbCkfree(
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
- memp->tagPtr->refCount--;
- if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
- TclpFree((char *) memp->tagPtr);
+ if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
+ TclpFree(memp->tagPtr);
}
}
@@ -650,7 +637,7 @@ Tcl_DbCkfree(
if (allocHead == memp) {
allocHead = memp->flink;
}
- TclpFree((char *) memp);
+ TclpFree(memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
@@ -675,7 +662,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,10 +676,10 @@ Tcl_DbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
- newPtr = Tcl_DbCkalloc(size, file, line);
+ newPtr = (char *)Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
@@ -706,7 +693,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,10 +707,10 @@ Tcl_AttemptDbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
- newPtr = Tcl_AttemptDbCkalloc(size, file, line);
+ newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line);
if (newPtr == NULL) {
return NULL;
}
@@ -808,13 +795,12 @@ Tcl_AttemptRealloc(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
MemoryCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int argc,
- const char *argv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
@@ -822,20 +808,17 @@ MemoryCmd(
int result;
size_t len;
- if (argc < 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s option [args..]\"", argv[0]));
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option [args..]");
return TCL_ERROR;
}
- if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s file\"",
- argv[0], argv[1]));
+ if (strcmp(TclGetString(objv[1]), "active") == 0 || strcmp(TclGetString(objv[1]), "display") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -843,44 +826,45 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
- argv[2], Tcl_PosixError(interp)));
+ TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
- if (strcmp(argv[1],"break_on_malloc") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
+ Tcl_WideInt value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ break_on_malloc = value;
return TCL_OK;
}
- if (strcmp(argv[1],"info") == 0) {
+ if (strcmp(TclGetString(objv[1]),"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
+ "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
- "current bytes allocated", (unsigned long)current_bytes_malloced,
+ "current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
- "maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
+ "maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
- if (strcmp(argv[1], "init") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]), "init") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- init_malloced_bodies = (strcmp(argv[2],"on") == 0);
+ init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1], "objs") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s objs file\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]), "objs") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -896,13 +880,12 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
return TCL_OK;
}
- if (strcmp(argv[1],"onexit") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s onexit file\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]),"onexit") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -911,60 +894,59 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
return TCL_OK;
}
- if (strcmp(argv[1],"tag") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s tag string\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]),"tag") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
- TclpFree((char *) curTagPtr);
+ TclpFree(curTagPtr);
}
- len = strlen(argv[2]);
+ len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
- memcpy(curTagPtr->string, argv[2], len + 1);
+ memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
- if (strcmp(argv[1],"trace") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"trace") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- alloc_tracing = (strcmp(argv[2],"on") == 0);
+ alloc_tracing = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) {
+ Tcl_WideInt value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ trace_on_at_malloc = value;
return TCL_OK;
}
- if (strcmp(argv[1],"validate") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"validate") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- validate_memory = (strcmp(argv[2],"on") == 0);
+ validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
- argv[1]));
+ TclGetString(objv[1])));
return TCL_ERROR;
argError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
+ Tcl_WrongNumArgs(interp, 2, objv, "count");
return TCL_ERROR;
bad_suboption:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
+ Tcl_WrongNumArgs(interp, 2, objv, "on|off");
return TCL_ERROR;
}
@@ -985,21 +967,19 @@ MemoryCmd(
*
*----------------------------------------------------------------------
*/
-
static int
CheckmemCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for evaluation. */
- int argc, /* Number of arguments. */
- const char *argv[]) /* String values of arguments. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
- if (argc != 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s fileName\"", argv[0]));
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
- strcpy(tclMemDumpFileName, argv[1]);
+ strcpy(tclMemDumpFileName, TclGetString(objv[1]));
return TCL_OK;
}
@@ -1025,8 +1005,8 @@ Tcl_InitMemory(
* added */
{
TclInitDbCkalloc();
- Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
@@ -1054,9 +1034,7 @@ char *
Tcl_Alloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
+ char *result = (char *)TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so that NULL
@@ -1080,9 +1058,7 @@ Tcl_DbCkalloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpAlloc(size);
+ char *result = (char *)TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1106,24 +1082,16 @@ char *
Tcl_AttemptAlloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
- return result;
+ return (char *)TclpAlloc(size);
}
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- char *result;
- (void)file;
- (void)line;
-
- result = (char *) TclpAlloc(size);
- return result;
+ return (char *)TclpAlloc(size);
}
/*
@@ -1142,9 +1110,7 @@ Tcl_Realloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
+ char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %u bytes", size);
@@ -1159,9 +1125,7 @@ Tcl_DbCkrealloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpRealloc(ptr, size);
+ char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1186,25 +1150,17 @@ Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
- return result;
+ return (char *)TclpRealloc(ptr, size);
}
char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- char *result;
- (void)file;
- (void)line;
-
- result = (char *) TclpRealloc(ptr, size);
- return result;
+ return (char *)TclpRealloc(ptr, size);
}
/*
@@ -1229,11 +1185,9 @@ Tcl_Free(
void
Tcl_DbCkfree(
char *ptr,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- (void)file;
- (void)line;
TclpFree(ptr);
}
@@ -1247,38 +1201,31 @@ Tcl_DbCkfree(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
void
Tcl_InitMemory(
- Tcl_Interp *interp)
+ TCL_UNUSED(Tcl_Interp *) /*interp*/)
{
- (void)interp;
}
int
Tcl_DumpActiveMemory(
- const char *fileName)
+ TCL_UNUSED(const char *) /*fileName*/)
{
- (void)fileName;
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- (void)file;
- (void)line;
}
int
TclDumpMemoryInfo(
- ClientData clientData,
- int flags)
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*flags*/)
{
- (void)clientData;
- (void)flags;
return 1;
}
@@ -1316,7 +1263,7 @@ TclFinalizeMemorySubsystem(void)
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
- TclpFree((char *) curTagPtr);
+ TclpFree(curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 13a5c65..d1f08c1 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -5,15 +5,16 @@
* the time and date facilities of TclX, by Mark Diekhans and Karl
* Lehenbauer.
*
- * Copyright (c) 1991-1995 Karl Lehenbauer & Mark Diekhans.
- * Copyright (c) 1995 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans.
+ * Copyright © 1995 Sun Microsystems, Inc.
+ * Copyright © 2004 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.
*/
#include "tclInt.h"
+#include "tclTomMath.h"
/*
* Windows has mktime. The configurators do not check.
@@ -109,7 +110,7 @@ typedef struct TclDateFields {
* Greenwich */
Tcl_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
- enum {BCE=1, CE=0} era; /* Era */
+ int isBce; /* 1 if BCE */
int gregorian; /* Flag == 1 if the date is Gregorian */
int year; /* Year of the era */
int dayOfYear; /* Day of the year (1 January == 1) */
@@ -160,39 +161,19 @@ 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,
- int objc, Tcl_Obj *const objv[]);
-static int ClockConvertlocaltoutcObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetdatefieldsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetjuliandayfromerayearmonthdayObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetjuliandayfromerayearweekdayObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetenvObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockMicrosecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockMillisecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockParseformatargsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockSecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ClockClicksObjCmd;
+static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd;
+static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd;
+static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd;
+static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd;
+static Tcl_ObjCmdProc ClockGetenvObjCmd;
+static Tcl_ObjCmdProc ClockMicrosecondsObjCmd;
+static Tcl_ObjCmdProc ClockMillisecondsObjCmd;
+static Tcl_ObjCmdProc ClockParseformatargsObjCmd;
+static Tcl_ObjCmdProc ClockSecondsObjCmd;
static struct tm * ThreadSafeLocalTime(const time_t *);
static void TzsetIfNecessary(void);
-static void ClockDeleteCmdProc(ClientData);
+static void ClockDeleteCmdProc(void *);
/*
* Structure containing description of "native" clock commands to create.
@@ -331,7 +312,7 @@ TclClockInit(
static int
ClockConvertlocaltoutcObjCmd(
- ClientData clientData, /* Client data */
+ void *clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -423,7 +404,7 @@ ClockConvertlocaltoutcObjCmd(
int
ClockGetdatefieldsObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -452,7 +433,7 @@ ClockGetdatefieldsObjCmd(
* that it isn't.
*/
- if (objv[1]->typePtr == &tclBignumType) {
+ if (TclHasInternalRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
@@ -488,27 +469,27 @@ ClockGetdatefieldsObjCmd(
Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET],
- Tcl_NewIntObj(fields.tzOffset));
+ Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN],
- Tcl_NewIntObj(fields.gregorian));
+ Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, lit[LIT_ERA],
- lit[fields.era ? LIT_BCE : LIT_CE]);
+ lit[fields.isBce ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR],
- Tcl_NewIntObj(fields.year));
+ Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR],
- Tcl_NewIntObj(fields.dayOfYear));
+ Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH],
- Tcl_NewIntObj(fields.month));
+ Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH],
- Tcl_NewIntObj(fields.dayOfMonth));
+ Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR],
- Tcl_NewIntObj(fields.iso8601Year));
+ Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
- Tcl_NewIntObj(fields.iso8601Week));
+ Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
- Tcl_NewIntObj(fields.dayOfWeek));
+ Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
@@ -577,7 +558,7 @@ FetchIntField(
static int
ClockGetjuliandayfromerayearmonthdayObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -589,7 +570,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -600,7 +581,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
return TCL_ERROR;
}
dict = objv[1];
- if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK
+ if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month)
@@ -610,7 +591,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -628,7 +609,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
@@ -661,7 +642,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
static int
ClockGetjuliandayfromerayearweekdayObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -673,7 +654,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -684,7 +665,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
return TCL_ERROR;
}
dict = objv[1];
- if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK
+ if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601YEAR],
&fields.iso8601Year) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601WEEK],
@@ -694,7 +675,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -712,7 +693,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
@@ -754,7 +735,7 @@ ConvertLocalToUTC(
* Unpack the tz data.
*/
- if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -819,7 +800,7 @@ ConvertLocalToUTCUsingTable(
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
- || TclListObjGetElements(interp, row, &cellc,
+ || TclListObjGetElementsM(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
&fields->tzOffset) != TCL_OK) {
@@ -957,7 +938,7 @@ ConvertUTCToLocal(
* Unpack the tz data.
*/
- if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1009,7 +990,7 @@ ConvertUTCToLocalUsingTable(
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
- TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
+ TclListObjGetElementsM(interp, row, &cellc, &cellv) != TCL_OK ||
TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
@@ -1079,7 +1060,7 @@ ConvertUTCToLocalUsingC(
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
- fields->era = CE;
+ fields->isBce = 0;
fields->year = timeVal->tm_year + 1900;
fields->month = timeVal->tm_mon + 1;
fields->dayOfMonth = timeVal->tm_mday;
@@ -1217,7 +1198,7 @@ GetYearWeekDay(
temp.julianDay = fields->julianDay - 3;
GetGregorianEraYearDay(&temp, changeover);
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year = temp.year - 1;
} else {
temp.iso8601Year = temp.year + 1;
@@ -1233,7 +1214,7 @@ GetYearWeekDay(
*/
if (fields->julianDay < temp.julianDay) {
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
@@ -1359,10 +1340,10 @@ GetGregorianEraYearDay(
*/
if (year <= 0) {
- fields->era = BCE;
+ fields->isBce = 1;
fields->year = 1 - year;
} else {
- fields->era = CE;
+ fields->isBce = 0;
fields->year = year;
}
fields->dayOfYear = day + 1;
@@ -1430,7 +1411,7 @@ GetJulianDayFromEraYearWeekDay(
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
- firstWeek.era = fields->era;
+ firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
firstWeek.dayOfMonth = 4;
@@ -1474,7 +1455,7 @@ GetJulianDayFromEraYearMonthDay(
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
@@ -1502,10 +1483,10 @@ GetJulianDayFromEraYearMonthDay(
fields->gregorian = 1;
if (year < 1) {
- fields->era = BCE;
+ fields->isBce = 1;
fields->year = 1-year;
} else {
- fields->era = CE;
+ fields->isBce = 0;
fields->year = year;
}
@@ -1580,7 +1561,7 @@ IsGregorianLeapYear(
{
int year = fields->year;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
@@ -1645,7 +1626,7 @@ WeekdayOnOrBefore(
int
ClockGetenvObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1658,28 +1639,28 @@ ClockGetenvObjCmd(
const char *varName;
const char *varValue;
#endif
- (void)clientData;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
#ifdef _WIN32
- varName = (const WCHAR *)Tcl_WinUtfToTChar(TclGetString(objv[1]), -1, &ds);
+ Tcl_DStringInit(&ds);
+ varName = Tcl_UtfToWCharDString(TclGetString(objv[1]), -1, &ds);
varValue = _wgetenv(varName);
- Tcl_DStringFree(&ds);
if (varValue == NULL) {
- varValue = L"";
+ Tcl_DStringFree(&ds);
+ } else {
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_WCharToUtfDString(varValue, -1, &ds);
+ Tcl_DStringResult(interp, &ds);
}
- Tcl_WinTCharToUtf((TCHAR *)varValue, -1, &ds);
- Tcl_DStringResult(interp, &ds);
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
- if (varValue == NULL) {
- varValue = "";
+ if (varValue != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
#endif
return TCL_OK;
}
@@ -1748,7 +1729,7 @@ ThreadSafeLocalTime(
int
ClockClicksObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
@@ -1762,7 +1743,6 @@ ClockClicksObjCmd(
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
- (void)clientData;
switch (objc) {
case 1:
@@ -1819,21 +1799,22 @@ ClockClicksObjCmd(
int
ClockMillisecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
+ Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
- now.sec * 1000 + now.usec / 1000));
+ TclNewUIntObj(timeObj, (Tcl_WideUInt)
+ now.sec * 1000 + now.usec / 1000);
+ Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
@@ -1857,12 +1838,11 @@ ClockMillisecondsObjCmd(
int
ClockMicrosecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
- (void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
@@ -1891,7 +1871,7 @@ ClockMicrosecondsObjCmd(
static int
ClockParseformatargsObjCmd(
- ClientData clientData, /* Client data containing literal pool */
+ void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -2009,20 +1989,22 @@ ClockParseformatargsObjCmd(
int
ClockSecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
+ Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
+ TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec);
+
+ Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
@@ -2110,7 +2092,7 @@ TzsetIfNecessary(void)
static void
ClockDeleteCmdProc(
- ClientData clientData) /* Opaque pointer to the client data */
+ void *clientData) /* Opaque pointer to the client data */
{
ClockClientData *data = (ClockClientData *)clientData;
int i;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 0bf5b8e..4f743cc 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -4,18 +4,19 @@
* This file contains the top-level command routines for most of the Tcl
* built-in commands whose names begin with the letters A to H.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
+#include "tclIO.h"
#ifdef _WIN32
# include "tclWinInt.h"
#endif
-#include <locale.h>
+#include "tclArithSeries.h"
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -46,7 +47,6 @@ struct ForeachState {
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
-static Tcl_ObjCmdProc BadEncodingSubcommand;
static Tcl_ObjCmdProc EncodingConvertfromObjCmd;
static Tcl_ObjCmdProc EncodingConverttoObjCmd;
static Tcl_ObjCmdProc EncodingDirsObjCmd;
@@ -61,7 +61,7 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
static const char * GetTypeFromMode(int mode);
static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
-static inline int EachloopCmd(Tcl_Interp *interp, int collect,
+static int EachloopCmd(Tcl_Interp *interp, int collect,
int objc, Tcl_Obj *const objv[]);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ExprCallback;
@@ -72,7 +72,6 @@ static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
static Tcl_NRPostProc EvalCmdErrMsg;
-static Tcl_ObjCmdProc BadFileSubcommand;
static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
@@ -122,7 +121,7 @@ static Tcl_ObjCmdProc PathTypeCmd;
int
Tcl_BreakObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -151,9 +150,10 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
int
Tcl_CaseObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -190,7 +190,7 @@ Tcl_CaseObjCmd(
if (caseObjc == 1) {
Tcl_Obj **newObjv;
- TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
+ TclListObjGetElementsM(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
@@ -267,6 +267,7 @@ Tcl_CaseObjCmd(
return TCL_OK;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -287,17 +288,17 @@ Tcl_CaseObjCmd(
int
Tcl_CatchObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -331,7 +332,7 @@ TclNRCatchObjCmd(
static int
CatchObjCmdCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -369,7 +370,7 @@ CatchObjCmdCallback(
}
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
@@ -392,7 +393,7 @@ CatchObjCmdCallback(
int
Tcl_CdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -447,7 +448,7 @@ Tcl_CdObjCmd(
int
Tcl_ConcatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -481,7 +482,7 @@ Tcl_ConcatObjCmd(
int
Tcl_ContinueObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -514,11 +515,11 @@ TclInitEncodingCmd(
Tcl_Interp* interp) /* Tcl interpreter */
{
static const EnsembleImplMap encodingImplMap[] = {
- {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -526,113 +527,6 @@ TclInitEncodingCmd(
}
/*
- *-----------------------------------------------------------------------------
- *
- * TclMakeEncodingCommandSafe --
- *
- * This function hides the unsafe 'dirs' and 'system' subcommands of
- * the "encoding" Tcl command ensemble. It must be called only from
- * TclHideUnsafeCommands.
- *
- * Results:
- * A standard Tcl result
- *
- * Side effects:
- * Adds commands to the table of hidden commands.
- *
- *-----------------------------------------------------------------------------
- */
-
-int
-TclMakeEncodingCommandSafe(
- Tcl_Interp* interp) /* Tcl interpreter */
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"convertfrom", 0},
- {"convertto", 0},
- {"dirs", 1},
- {"names", 0},
- {"system", 0},
- {NULL, 0}
- };
-
- int i;
- Tcl_DString oldBuf, newBuf;
-
- Tcl_DStringInit(&oldBuf);
- TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:encoding:");
- for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
- if (unsafeInfo[i].unsafe) {
- const char *oldName, *newName;
-
- Tcl_DStringSetLength(&oldBuf, 17);
- oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
- Tcl_DStringSetLength(&newBuf, 13);
- 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 'encoding %s' safe: %s",
- unsafeInfo[i].cmdName,
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
-
- /*
- * Ugh. The [encoding] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies.
- */
-
- if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) {
- Tcl_Panic("problem making 'encoding' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * BadEncodingSubcommand --
- *
- * Command used to act as a backstop implementation when subcommands of
- * "encoding" are unsafe (the real implementations of the subcommands are
- * hidden). The clientData is always the full official subcommand name.
- *
- * Results:
- * A standard Tcl result (always a TCL_ERROR).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-BadEncodingSubcommand(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- const char *subcommandName = (const char *) clientData;
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "not allowed to invoke subcommand %s of encoding", subcommandName));
- Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
- return TCL_ERROR;
-}
-
-/*
*----------------------------------------------------------------------
*
* EncodingConvertfromObjCmd --
@@ -648,7 +542,7 @@ BadEncodingSubcommand(
int
EncodingConvertfromObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -658,32 +552,128 @@ EncodingConvertfromObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+ int flags = TCL_ENCODING_STOPONERROR;
+#else
+ int flags = TCL_ENCODING_NOCOMPLAIN;
+#endif
+ int result;
+ Tcl_Obj *failVarObj = NULL;
+ /*
+ * Decode parameters:
+ * Possible combinations:
+ * 1) data -> objc = 2
+ * 2) encoding data -> objc = 3
+ * 3) -nocomplain data -> objc = 3
+ * 4) -nocomplain encoding data -> objc = 4
+ * 5) -strict data -> objc = 3
+ * 6) -strict encoding data -> objc = 4
+ * 7) -failindex val data -> objc = 4
+ * 8) -failindex val encoding data -> objc = 5
+ */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
+ } else if (objc > 2 && objc < 7) {
+ int objcUnprocessed = objc;
+ data = objv[objc - 1];
+ bytesPtr = Tcl_GetString(objv[1]);
+ if (bytesPtr[0] == '-' && bytesPtr[1] == 'n'
+ && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) {
+ flags = TCL_ENCODING_NOCOMPLAIN;
+ objcUnprocessed--;
+ } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's'
+ && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) {
+ flags = TCL_ENCODING_STRICT;
+ objcUnprocessed--;
+ bytesPtr = Tcl_GetString(objv[2]);
+ if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
+ && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 6) {
+ goto encConvFromError;
+ }
+ failVarObj = objv[3];
+ objcUnprocessed -= 2;
+ }
+ } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
+ && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 4) {
+ goto encConvFromError;
+ }
+ failVarObj = objv[2];
+ flags = ENCODING_FAILINDEX;
+ objcUnprocessed -= 2;
+ bytesPtr = Tcl_GetString(objv[3]);
+ if (bytesPtr[0] == '-' && bytesPtr[1] == 's'
+ && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) {
+ flags = TCL_ENCODING_STRICT;
+ objcUnprocessed --;
+ }
+ }
+ switch (objcUnprocessed) {
+ case 3:
+ if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case 2:
+ encoding = Tcl_GetEncoding(interp, NULL);
+ break;
+ default:
+ goto encConvFromError;
}
- data = objv[2];
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ encConvFromError:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data");
+ ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
+ Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data");
return TCL_ERROR;
}
/*
* Convert the string into a byte array in 'ds'
*/
- bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
- Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ if (!(flags & TCL_ENCODING_STOPONERROR)) {
+ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ } else
+#endif
+ bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length);
+ if (bytesPtr == NULL) {
+ return TCL_ERROR;
+ }
+ result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length,
+ flags, &ds);
+ if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) {
+ if (failVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ char buf[TCL_INTEGER_SPACE];
+ sprintf(buf, "%u", result);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %"
+ "u: '\\x%X'", result, UCHAR(bytesPtr[result])));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
+ buf, NULL);
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ } else if (failVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ }
/*
* Note that we cannot use Tcl_DStringResult here because it will
* truncate the string at the first null byte.
*/
- Tcl_SetObjResult(interp, TclDStringToObj(&ds));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds));
/*
* We're done with the encoding
@@ -710,7 +700,7 @@ EncodingConvertfromObjCmd(
int
EncodingConverttoObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -720,17 +710,84 @@ EncodingConverttoObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
+ int result;
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+ int flags = TCL_ENCODING_STOPONERROR;
+#else
+ int flags = TCL_ENCODING_NOCOMPLAIN;
+#endif
+ Tcl_Obj *failVarObj = NULL;
+
+ /*
+ * Decode parameters:
+ * Possible combinations:
+ * 1) data -> objc = 2
+ * 2) encoding data -> objc = 3
+ * 3) -nocomplain data -> objc = 3
+ * 4) -nocomplain encoding data -> objc = 4
+ * 5) -failindex val data -> objc = 4
+ * 6) -failindex val encoding data -> objc = 5
+ */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
+ } else if (objc > 2 && objc < 7) {
+ int objcUnprocessed = objc;
+ data = objv[objc - 1];
+ stringPtr = Tcl_GetString(objv[1]);
+ if (stringPtr[0] == '-' && stringPtr[1] == 'n'
+ && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) {
+ flags = TCL_ENCODING_NOCOMPLAIN;
+ objcUnprocessed--;
+ } else if (stringPtr[0] == '-' && stringPtr[1] == 's'
+ && !strncmp(stringPtr, "-strict", strlen(stringPtr))) {
+ flags = TCL_ENCODING_STRICT;
+ objcUnprocessed--;
+ stringPtr = Tcl_GetString(objv[2]);
+ if (stringPtr[0] == '-' && stringPtr[1] == 'f'
+ && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 6) {
+ goto encConvToError;
+ }
+ failVarObj = objv[3];
+ objcUnprocessed -= 2;
+ }
+ } else if (stringPtr[0] == '-' && stringPtr[1] == 'f'
+ && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 4) {
+ goto encConvToError;
+ }
+ failVarObj = objv[2];
+ flags = TCL_ENCODING_STOPONERROR;
+ objcUnprocessed -= 2;
+ stringPtr = Tcl_GetString(objv[3]);
+ if (stringPtr[0] == '-' && stringPtr[1] == 's'
+ && !strncmp(stringPtr, "-strict", strlen(stringPtr))) {
+ flags = TCL_ENCODING_STRICT;
+ objcUnprocessed --;
+ }
+ }
+ switch (objcUnprocessed) {
+ case 3:
+ if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case 2:
+ encoding = Tcl_GetEncoding(interp, NULL);
+ break;
+ default:
+ goto encConvToError;
}
- data = objv[2];
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ encConvToError:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data");
+ ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
+ Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data");
+
return TCL_ERROR;
}
@@ -739,7 +796,32 @@ EncodingConverttoObjCmd(
*/
stringPtr = TclGetStringFromObj(data, &length);
- Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
+ result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length,
+ flags, &ds);
+ if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) {
+ if (failVarObj != NULL) {
+ /* I hope, wide int will cover size_t data type */
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ size_t pos = Tcl_NumUtfChars(stringPtr, result);
+ int ucs4;
+ char buf[TCL_INTEGER_SPACE];
+ TclUtfToUCS4(&stringPtr[result], &ucs4);
+ sprintf(buf, "%u", result);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %"
+ TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
+ buf, NULL);
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ } else if (failVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ }
Tcl_SetObjResult(interp,
Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
@@ -772,7 +854,7 @@ EncodingConverttoObjCmd(
int
EncodingDirsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -816,7 +898,7 @@ EncodingDirsObjCmd(
int
EncodingNamesObjCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
@@ -847,7 +929,7 @@ EncodingNamesObjCmd(
int
EncodingSystemObjCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
@@ -884,7 +966,7 @@ EncodingSystemObjCmd(
int
Tcl_ErrorObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -933,7 +1015,7 @@ Tcl_ErrorObjCmd(
static int
EvalCmdErrMsg(
- ClientData data[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -946,17 +1028,17 @@ EvalCmdErrMsg(
int
Tcl_EvalObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1015,12 +1097,12 @@ TclNREvalObjCmd(
int
Tcl_ExitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int value;
+ Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
@@ -1029,10 +1111,10 @@ Tcl_ExitObjCmd(
if (objc == 1) {
value = 0;
- } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ } else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_Exit(value);
+ Tcl_Exit((int)value);
return TCL_OK; /* Better not ever reach this! */
}
@@ -1062,17 +1144,17 @@ Tcl_ExitObjCmd(
int
Tcl_ExprObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1099,7 +1181,7 @@ TclNRExprObjCmd(
static int
ExprCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1149,40 +1231,43 @@ TclInitFileCmd(
*/
static const EnsembleImplMap initMap[] = {
- {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
+ {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
+ {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1},
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
- {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1},
+ {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
- {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
- {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
- {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1},
+ {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
+ {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
+ {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
- {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1},
+ {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
- {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
+ {"tildeexpand", TclFileTildeExpandCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
+ {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
@@ -1191,141 +1276,6 @@ TclInitFileCmd(
/*
*----------------------------------------------------------------------
*
- * 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);
- TclDStringAppendLiteral(&oldBuf, "::tcl::file::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:file:");
- 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_CreateObjCommand(interp, oldName, BadFileSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
-
- /*
- * Ugh. The [file] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies. [Bug
- * 3211758]
- */
-
- if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) {
- Tcl_Panic("problem making 'file' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * BadFileSubcommand --
- *
- * Command used to act as a backstop implementation when subcommands of
- * "file" are unsafe (the real implementations of the subcommands are
- * hidden). The clientData is always the full official subcommand name.
- *
- * Results:
- * A standard Tcl result (always a TCL_ERROR).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-BadFileSubcommand(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- const char *subcommandName = (const char *) clientData;
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "not allowed to invoke subcommand %s of file", subcommandName));
- Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
@@ -1342,7 +1292,7 @@ BadFileSubcommand(
static int
FileAttrAccessTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1368,9 +1318,14 @@ FileAttrAccessTimeCmd(
#endif
if (objc == 3) {
+ /*
+ * Need separate variable for reading longs from an object on 64-bit
+ * platforms. [Bug 698146]
+ */
+
Tcl_WideInt newTime;
- if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1419,7 +1374,7 @@ FileAttrAccessTimeCmd(
static int
FileAttrModifyTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1451,7 +1406,7 @@ FileAttrModifyTimeCmd(
Tcl_WideInt newTime;
- if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1498,21 +1453,25 @@ FileAttrModifyTimeCmd(
static int
FileAttrLinkStatCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[2], &buf);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -1534,21 +1493,25 @@ FileAttrLinkStatCmd(
static int
FileAttrStatCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || 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);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -1570,7 +1533,7 @@ FileAttrStatCmd(
static int
FileAttrTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1608,7 +1571,7 @@ FileAttrTypeCmd(
static int
FileAttrSizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1645,7 +1608,7 @@ FileAttrSizeCmd(
static int
FileAttrIsDirectoryCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1683,7 +1646,7 @@ FileAttrIsDirectoryCmd(
static int
FileAttrIsExecutableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1714,7 +1677,7 @@ FileAttrIsExecutableCmd(
static int
FileAttrIsExistingCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1745,7 +1708,7 @@ FileAttrIsExistingCmd(
static int
FileAttrIsFileCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1783,7 +1746,7 @@ FileAttrIsFileCmd(
static int
FileAttrIsOwnedCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1830,7 +1793,7 @@ FileAttrIsOwnedCmd(
static int
FileAttrIsReadableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1861,7 +1824,7 @@ FileAttrIsReadableCmd(
static int
FileAttrIsWritableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1892,7 +1855,7 @@ FileAttrIsWritableCmd(
static int
PathDirNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1931,7 +1894,7 @@ PathDirNameCmd(
static int
PathExtensionCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1970,7 +1933,7 @@ PathExtensionCmd(
static int
PathRootNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2009,7 +1972,7 @@ PathRootNameCmd(
static int
PathTailCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2048,7 +2011,7 @@ PathTailCmd(
static int
PathFilesystemCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2089,7 +2052,7 @@ PathFilesystemCmd(
static int
PathJoinCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2121,7 +2084,7 @@ PathJoinCmd(
static int
PathNativeNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2135,7 +2098,7 @@ PathNativeNameCmd(
if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclDStringToObj(&ds));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds));
return TCL_OK;
}
@@ -2158,7 +2121,7 @@ PathNativeNameCmd(
static int
PathNormalizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2196,7 +2159,7 @@ PathNormalizeCmd(
static int
PathSplitCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2207,7 +2170,7 @@ PathSplitCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- res = Tcl_FSSplitPath(objv[1], NULL);
+ res = Tcl_FSSplitPath(objv[1], (int *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
@@ -2239,7 +2202,7 @@ PathSplitCmd(
static int
PathTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2287,7 +2250,7 @@ PathTypeCmd(
static int
FilesystemSeparatorCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2342,7 +2305,7 @@ FilesystemSeparatorCmd(
static int
FilesystemVolumesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2448,7 +2411,7 @@ GetStatBuf(
*
* This is a utility procedure that breaks out the fields of a "stat"
* structure and stores them in textual form into the elements of an
- * associative array.
+ * associative array (if given) or returns a dictionary.
*
* Results:
* Returns a standard Tcl return value. If an error occurs then a message
@@ -2468,9 +2431,40 @@ StoreStatData(
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
- Tcl_Obj *field, *value;
+ Tcl_Obj *field, *value, *result;
unsigned short mode;
+ if (varName == NULL) {
+ result = Tcl_NewObj();
+ Tcl_IncrRefCount(result);
+#define DOBJPUT(key, objValue) \
+ Tcl_DictObjPut(NULL, result, \
+ Tcl_NewStringObj((key), -1), \
+ (objValue));
+ DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
+ DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
+ DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
+ DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
+ DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
+#endif
+ DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
+ DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
+ DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
+ mode = (unsigned short) statPtr->st_mode;
+ DOBJPUT("mode", Tcl_NewWideIntObj(mode));
+ DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
+#undef DOBJPUT
+ Tcl_SetObjResult(interp, result);
+ Tcl_DecrRefCount(result);
+ return TCL_OK;
+ }
+
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
@@ -2494,23 +2488,23 @@ StoreStatData(
* cast might fail when there isn't a real arithmetic 'long long' type...
*/
- STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
- STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
- STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
- STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
- STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
- STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+ STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
+ STORE_ARY("ino", Tcl_NewWideIntObj(statPtr->st_ino));
+ STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
+ STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
+ STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
+ STORE_ARY("size", Tcl_NewWideIntObj(statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+ STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize));
+ STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
- STORE_ARY("mode", Tcl_NewIntObj(mode));
+ STORE_ARY("mode", Tcl_NewWideIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
@@ -2602,17 +2596,17 @@ GetTypeFromMode(
int
Tcl_ForObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2643,7 +2637,7 @@ TclNRForObjCmd(
static int
ForSetupCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2662,7 +2656,7 @@ ForSetupCallback(
int
TclNRForIterCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2697,7 +2691,7 @@ TclNRForIterCallback(
static int
ForCondCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2735,7 +2729,7 @@ ForCondCallback(
static int
ForNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2760,7 +2754,7 @@ ForNextCallback(
static int
ForPostNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2796,17 +2790,17 @@ ForPostNextCallback(
int
Tcl_ForeachObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2816,17 +2810,17 @@ TclNRForeachCmd(
int
Tcl_LmapObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2834,7 +2828,7 @@ TclNRLmapCmd(
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
-static inline int
+static int
EachloopCmd(
Tcl_Interp *interp, /* Our context for variables and script
* evaluation. */
@@ -2897,32 +2891,49 @@ EachloopCmd(
*/
for (i=0 ; i<numLists ; i++) {
+ /* List */
+ /* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, statePtr->vCopyList[i],
- &statePtr->varcList[i], &statePtr->varvList[i]);
+ TclListObjLengthM(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s varlist is empty",
- (statePtr->resultList != NULL ? "lmap" : "foreach")));
+ "%s varlist is empty",
+ (statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
- (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
- "NEEDVARS", NULL);
+ (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
+ "NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
-
- statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (statePtr->aCopyList[i] == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- TclListObjGetElements(NULL, statePtr->aCopyList[i],
+ TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i], &statePtr->varvList[i]);
+
+ /* Values */
+ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) {
+ /* Special case for Arith Series */
+ statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ /* Don't compute values here, wait until the last momement */
+ statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]);
+ } else {
+ /* List values */
+ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
-
+ }
+ /* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
@@ -2965,7 +2976,7 @@ EachloopCmd(
static int
ForeachLoopStep(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3044,10 +3055,22 @@ ForeachAssignments(
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
+ int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType);
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
- valuePtr = statePtr->argvList[i][k];
+ if (isarithseries) {
+ valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k);
+ if (valuePtr == NULL) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (setting %s loop variable \"%s\")",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
+ TclGetString(statePtr->varvList[i][v])));
+ return TCL_ERROR;
+ }
+ } else {
+ valuePtr = statePtr->argvList[i][k];
+ }
} else {
TclNewObj(valuePtr); /* Empty string */
}
@@ -3112,7 +3135,7 @@ ForeachCleanup(
int
Tcl_FormatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 75e572d..1838f7f 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -6,12 +6,12 @@
* 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.
- * Copyright (c) 1993-1997 Lucent Technologies.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2005 Donal K. Fellows.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1993-1997 Lucent Technologies.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 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,6 +19,10 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tclArithSeries.h"
+#include "tclTomMath.h"
+#include <math.h>
+#include <assert.h>
/*
* During execution of the "lsort" command, structures of the following type
@@ -56,7 +60,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
* The following structure is used to pass this information.
*/
-typedef struct SortInfo {
+typedef struct {
int isIncreasing; /* Nonzero means sort in increasing order. */
int sortMode; /* The sort mode. One of SORTMODE_* values
* defined below. */
@@ -94,52 +98,50 @@ typedef struct SortInfo {
#define SORTMODE_ASCII_NC 8
/*
+ * Definitions for [lseq] command
+ */
+static const char *const seq_operations[] = {
+ "..", "to", "count", "by", NULL
+};
+typedef enum Sequence_Operators {
+ LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
+} SequenceOperators;
+static const char *const seq_step_keywords[] = {"by", NULL};
+typedef enum Step_Operators {
+ STEP_BY = 4
+} SequenceByMode;
+typedef enum Sequence_Decoded {
+ NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg
+} SequenceDecoded;
+
+/*
* Forward declarations for procedures defined in this file:
*/
static int DictionaryCompare(const char *left, const char *right);
static Tcl_NRPostProc IfConditionCallback;
-static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoArgsCmd;
+static Tcl_ObjCmdProc InfoBodyCmd;
+static Tcl_ObjCmdProc InfoCmdCountCmd;
+static Tcl_ObjCmdProc InfoCommandsCmd;
+static Tcl_ObjCmdProc InfoCompleteCmd;
+static Tcl_ObjCmdProc InfoDefaultCmd;
/* TIP #348 - New 'info' subcommand 'errorstack' */
-static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoErrorStackCmd;
/* TIP #280 - New 'info' subcommand 'frame' */
-static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoNameOfExecutableCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoFrameCmd;
+static Tcl_ObjCmdProc InfoFunctionsCmd;
+static Tcl_ObjCmdProc InfoHostnameCmd;
+static Tcl_ObjCmdProc InfoLevelCmd;
+static Tcl_ObjCmdProc InfoLibraryCmd;
+static Tcl_ObjCmdProc InfoLoadedCmd;
+static Tcl_ObjCmdProc InfoNameOfExecutableCmd;
+static Tcl_ObjCmdProc InfoPatchLevelCmd;
+static Tcl_ObjCmdProc InfoProcsCmd;
+static Tcl_ObjCmdProc InfoScriptCmd;
+static Tcl_ObjCmdProc InfoSharedlibCmd;
+static Tcl_ObjCmdProc InfoCmdTypeCmd;
+static Tcl_ObjCmdProc InfoTclVersionCmd;
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
@@ -156,6 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
@@ -170,7 +173,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
@@ -203,17 +206,17 @@ static const EnsembleImplMap defaultInfoMap[] = {
int
Tcl_IfObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -386,7 +389,7 @@ IfConditionCallback(
int
Tcl_IncrObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -467,7 +470,7 @@ TclInitInfoCmd(
static int
InfoArgsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -530,15 +533,15 @@ InfoArgsCmd(
static int
InfoBodyCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- const char *name;
+ const char *name, *bytes;
Proc *procPtr;
- Tcl_Obj *bodyPtr, *resultPtr;
+ int numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
@@ -563,18 +566,8 @@ InfoBodyCmd(
* the object do not invalidate the internal rep.
*/
- bodyPtr = procPtr->bodyPtr;
- if (bodyPtr->bytes == NULL) {
- /*
- * The string rep might not be valid if the procedure has never been
- * run before. [Bug #545644]
- */
-
- TclGetString(bodyPtr);
- }
- resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
-
- Tcl_SetObjResult(interp, resultPtr);
+ bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
@@ -601,7 +594,7 @@ InfoBodyCmd(
static int
InfoCmdCountCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -613,7 +606,7 @@ InfoCmdCountCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount));
return TCL_OK;
}
@@ -643,7 +636,7 @@ InfoCmdCountCmd(
static int
InfoCommandsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -920,7 +913,7 @@ InfoCommandsCmd(
static int
InfoCompleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -957,7 +950,7 @@ InfoCompleteCmd(
static int
InfoDefaultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -995,7 +988,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
} else {
Tcl_Obj *nullObjPtr;
@@ -1005,7 +998,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -1040,7 +1033,7 @@ InfoDefaultCmd(
static int
InfoErrorStackCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1055,7 +1048,7 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetChild(interp, Tcl_GetString(objv[1]));
+ target = Tcl_GetChild(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
@@ -1089,7 +1082,7 @@ InfoErrorStackCmd(
int
TclInfoExistsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1134,7 +1127,7 @@ TclInfoExistsCmd(
static int
InfoFrameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1179,7 +1172,7 @@ InfoFrameCmd(
* Just "info frame".
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel));
goto done;
}
@@ -1301,9 +1294,9 @@ TclInfoFrame(
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
if (framePtr->line) {
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
} else {
- ADD_PAIR("line", Tcl_NewIntObj(1));
+ ADD_PAIR("line", Tcl_NewWideIntObj(1));
}
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
@@ -1340,7 +1333,7 @@ TclInfoFrame(
ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
if (fPtr->line) {
- ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0]));
}
if (fPtr->type == TCL_LOCATION_SOURCE) {
@@ -1367,7 +1360,7 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
ADD_PAIR("file", framePtr->data.eval.path);
/*
@@ -1438,7 +1431,7 @@ TclInfoFrame(
int c = framePtr->framePtr->level;
int t = iPtr->varFramePtr->level;
- ADD_PAIR("level", Tcl_NewIntObj(t - c));
+ ADD_PAIR("level", Tcl_NewWideIntObj(t - c));
break;
}
}
@@ -1474,7 +1467,7 @@ TclInfoFrame(
static int
InfoFunctionsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1539,7 +1532,7 @@ InfoFunctionsCmd(
static int
InfoHostnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1585,7 +1578,7 @@ InfoHostnameCmd(
static int
InfoLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1593,7 +1586,7 @@ InfoLevelCmd(
Interp *iPtr = (Interp *) interp;
if (objc == 1) { /* Just "info level" */
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level));
return TCL_OK;
}
@@ -1659,7 +1652,7 @@ InfoLevelCmd(
static int
InfoLibraryCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1671,7 +1664,7 @@ InfoLibraryCmd(
return TCL_ERROR;
}
- libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
@@ -1706,24 +1699,29 @@ InfoLibraryCmd(
static int
InfoLoadedCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *interpName;
+ const char *interpName, *packageName;
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
return TCL_ERROR;
}
- if (objc == 1) { /* Get loaded pkgs in all interpreters. */
+ if (objc < 2) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
- return TclGetLoadedPackages(interp, interpName);
+ if (objc < 3) { /* Get loaded files in all packages. */
+ packageName = NULL;
+ } else { /* Get pkgs just in specified interp. */
+ packageName = TclGetString(objv[2]);
+ }
+ return TclGetLoadedLibraries(interp, interpName, packageName);
}
/*
@@ -1749,7 +1747,7 @@ InfoLoadedCmd(
static int
InfoNameOfExecutableCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1785,7 +1783,7 @@ InfoNameOfExecutableCmd(
static int
InfoPatchLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1797,7 +1795,7 @@ InfoPatchLevelCmd(
return TCL_ERROR;
}
- patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
+ patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
@@ -1832,7 +1830,7 @@ InfoPatchLevelCmd(
static int
InfoProcsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1930,7 +1928,7 @@ InfoProcsCmd(
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
- TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ TclGetOriginalCommand((Tcl_Command)cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
@@ -1938,7 +1936,7 @@ InfoProcsCmd(
procOK:
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
- Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
+ Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -1969,11 +1967,11 @@ InfoProcsCmd(
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
@@ -2019,12 +2017,13 @@ InfoProcsCmd(
static int
InfoScriptCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
+
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?filename?");
return TCL_ERROR;
@@ -2066,7 +2065,7 @@ InfoScriptCmd(
static int
InfoSharedlibCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2104,7 +2103,7 @@ InfoSharedlibCmd(
static int
InfoTclVersionCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2128,6 +2127,60 @@ InfoTclVersionCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoCmdTypeCmd --
+ *
+ * Called to implement the "info cmdtype" command that returns the type
+ * of a given command. Handles the following syntax:
+ *
+ * info cmdtype cmdName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a type name. If there is an error, the result is an error
+ * message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCmdTypeCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Command command;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "commandName");
+ return TCL_ERROR;
+ }
+ command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (command == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * There's one special case: safe interpreters can't see aliases as
+ * aliases as they're part of the security mechanisms.
+ */
+
+ if (Tcl_IsSafe(interp)
+ && (((Command *) command)->objProc == TclAliasObjCmd)) {
+ Tcl_AppendResult(interp, "native", NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
@@ -2144,13 +2197,13 @@ InfoTclVersionCmd(
int
Tcl_JoinObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int listLen, i;
- Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
+ int length, listLen, isArithSeries = 0;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2162,32 +2215,88 @@ Tcl_JoinObjCmd(
* pointer to its array of element pointers.
*/
- if (TclListObjGetElements(interp, objv[1], &listLen,
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ isArithSeries = 1;
+ listLen = TclArithSeriesObjLength(objv[1]);
+ } else {
+ if (TclListObjGetElementsM(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
+ }
+ }
+
+ if (listLen == 0) {
+ /* No elements to join; default empty result is correct. */
+ return TCL_OK;
+ }
+ if (listLen == 1) {
+ /* One element; return it */
+ if (isArithSeries) {
+ Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0);
+ if (valueObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, valueObj);
+ } else {
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ }
+ return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- TclNewObj(resObjPtr);
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ (void) TclGetStringFromObj(joinObjPtr, &length);
+ if (length == 0) {
+ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
+ } else {
+ int i;
+
+ TclNewObj(resObjPtr);
+ if (isArithSeries) {
+ Tcl_Obj *valueObj;
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
+
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ valueObj = TclArithSeriesObjIndex(interp, objv[1], i);
+ if (valueObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendObjToObj(resObjPtr, valueObj);
+ Tcl_DecrRefCount(valueObj);
+ }
+ } else {
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
- /*
- * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
- * to shimmer joinObjPtr. If it did, then the case where
- * objv[1] and objv[2] are the same value would not be safe.
- * Accessing elemPtrs would crash.
- */
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
+ }
}
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_DecrRefCount(joinObjPtr);
- Tcl_SetObjResult(interp, resObjPtr);
- return TCL_OK;
+ if (resObjPtr) {
+ Tcl_SetObjResult(interp, resObjPtr);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
}
/*
@@ -2209,7 +2318,7 @@ Tcl_JoinObjCmd(
int
Tcl_LassignObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2229,7 +2338,7 @@ Tcl_LassignObjCmd(
return TCL_ERROR;
}
- TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv);
+ TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv);
objc -= 2;
objv += 2;
@@ -2283,12 +2392,11 @@ Tcl_LassignObjCmd(
int
Tcl_LindexObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
-
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
@@ -2342,7 +2450,7 @@ Tcl_LindexObjCmd(
int
Tcl_LinsertObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2355,7 +2463,7 @@ Tcl_LinsertObjCmd(
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &len);
+ result = TclListObjLengthM(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
@@ -2424,7 +2532,7 @@ Tcl_LinsertObjCmd(
int
Tcl_ListObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
@@ -2460,20 +2568,21 @@ Tcl_ListObjCmd(
int
Tcl_LlengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
+ Tcl_Obj *objPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2483,7 +2592,109 @@ Tcl_LlengthObjCmd(
* length.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
+ TclNewUIntObj(objPtr, listLen);
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LpopObjCmd --
+ *
+ * This procedure is invoked to process the "lpop" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LpopObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[])
+ /* Argument objects. */
+{
+ int listLen, result;
+ Tcl_Obj *elemPtr, *stored;
+ Tcl_Obj *listPtr, **elemPtrs;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ result = TclListObjGetElementsM(interp, listPtr, &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /*
+ * First, extract the element to be returned.
+ * TclLindexFlat adds a ref count which is handled.
+ */
+
+ if (objc == 2) {
+ if (!listLen) {
+ /* empty list, throw the same error as with index "end" */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "index \"end\" out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
+ "OUTOFRANGE", NULL);
+ return TCL_ERROR;
+ }
+ elemPtr = elemPtrs[listLen - 1];
+ Tcl_IncrRefCount(elemPtr);
+ } else {
+ elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
+
+ if (elemPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount(elemPtr);
+
+ /*
+ * Second, remove the element.
+ * TclLsetFlat adds a ref count which is handled.
+ */
+
+ if (objc == 2) {
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ }
+ result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_IncrRefCount(listPtr);
+ } else {
+ listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
+
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(listPtr);
+ if (stored == NULL) {
+ return TCL_ERROR;
+ }
+
return TCL_OK;
}
@@ -2506,21 +2717,19 @@ Tcl_LlengthObjCmd(
int
Tcl_LrangeObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj **elemPtrs;
int listLen, first, last, result;
-
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2530,55 +2739,158 @@ Tcl_LrangeObjCmd(
if (result != TCL_OK) {
return result;
}
- 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;
+
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_Obj *rangeObj;
+ rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last);
+ if (rangeObj) {
+ Tcl_SetObjResult(interp, rangeObj);
+ } else {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
}
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LremoveObjCmd --
+ *
+ * This procedure is invoked to process the "lremove" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- if (first > last) {
- /*
- * Returning an empty list is easy.
- */
+static int
+LremoveIndexCompare(
+ const void *el1Ptr,
+ const void *el2Ptr)
+{
+ int idx1 = *((const int *) el1Ptr);
+ int idx2 = *((const int *) el2Ptr);
+
+ /*
+ * This will put the larger element first.
+ */
+
+ return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
+}
+
+int
+Tcl_LremoveObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int i, idxc, listLen, prevIdx, first, num;
+ int *idxv;
+ Tcl_Obj *listObj;
+
+ /*
+ * Parse the arguments.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
+ return TCL_ERROR;
+ }
+
+ listObj = objv[1];
+ if (TclListObjLengthM(interp, listObj, &listLen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ idxc = objc - 2;
+ if (idxc == 0) {
+ Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
+ idxv = (int *)ckalloc((objc - 2) * sizeof(int));
+ for (i = 2; i < objc; i++) {
+ if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
+ &idxv[i - 2]) != TCL_OK) {
+ ckfree(idxv);
+ return TCL_ERROR;
+ }
+ }
- result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
+ /*
+ * Sort the indices, large to small so that when we remove an index we
+ * don't change the indices still to be processed.
+ */
+
+ if (idxc > 1) {
+ qsort(idxv, idxc, sizeof(int), LremoveIndexCompare);
}
- if (Tcl_IsShared(objv[1]) ||
- ((ListRepPtr(objv[1])->refCount > 1))) {
- Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
- &elemPtrs[first]));
- } else {
+ /*
+ * Make our working copy, then do the actual removes piecemeal.
+ */
+
+ if (Tcl_IsShared(listObj)) {
+ listObj = TclListObjCopy(NULL, listObj);
+ }
+ num = 0;
+ first = listLen;
+ for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
+ int idx = idxv[i];
+
/*
- * In-place is possible.
+ * Repeated index and sanity check.
*/
- if (last < (listLen - 1)) {
- Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
- 0, NULL);
+ if (idx == prevIdx) {
+ continue;
+ }
+ prevIdx = idx;
+ if (idx < 0 || idx >= listLen) {
+ continue;
}
/*
- * This one is not conditioned on (first > 0) in order to preserve the
- * string-canonizing effect of [lrange 0 end].
+ * Coalesce adjacent removes to reduce the number of copies.
*/
- Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
- Tcl_SetObjResult(interp, objv[1]);
- }
+ if (num == 0) {
+ num = 1;
+ first = idx;
+ } else if (idx + 1 == first) {
+ num++;
+ first = idx;
+ } else {
+ /*
+ * Note that this operation can't fail now; we know we have a list
+ * and we're only ever contracting that list.
+ */
+ (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ listLen -= num;
+ num = 1;
+ first = idx;
+ }
+ }
+ if (num != 0) {
+ (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ }
+ ckfree(idxv);
+ Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
@@ -2601,7 +2913,7 @@ Tcl_LrangeObjCmd(
int
Tcl_LrepeatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
@@ -2654,10 +2966,15 @@ Tcl_LrepeatObjCmd(
listPtr = Tcl_NewListObj(totalElems, NULL);
if (totalElems) {
- List *listRepPtr = ListRepPtr(listPtr);
-
- listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ ListRep listRep;
+ ListObjGetRep(listPtr, &listRep);
+ dataArray = ListRepElementsBase(&listRep);
+ listRep.storePtr->numUsed = totalElems;
+ if (listRep.spanPtr) {
+ /* Future proofing in case Tcl_NewListObj returns a span */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
}
/*
@@ -2710,13 +3027,14 @@ Tcl_LrepeatObjCmd(
int
Tcl_LreplaceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
- int first, last, listLen, numToDelete, result;
+ int first, last;
+ int listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2724,7 +3042,7 @@ Tcl_LreplaceObjCmd(
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2745,10 +3063,9 @@ Tcl_LreplaceObjCmd(
return result;
}
- if (first < 0) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
- }
- if (first > listLen) {
+ } else if (first > listLen) {
first = listLen;
}
@@ -2811,7 +3128,7 @@ Tcl_LreplaceObjCmd(
int
Tcl_LreverseObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -2823,7 +3140,23 @@ Tcl_LreverseObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+
+ /*
+ * Handle ArithSeries special case - don't shimmer a series into a list
+ * just to reverse it.
+ */
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]);
+ if (resObj) {
+ Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+ } /* end ArithSeries */
+
+ /* True List */
+ if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
@@ -2835,16 +3168,26 @@ Tcl_LreverseObjCmd(
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
+ if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+ return TCL_ERROR;
+ }
if (Tcl_IsShared(objv[1])
- || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */
+ || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
- List *listRepPtr;
+ ListRep listRep;
resultObj = Tcl_NewListObj(elemc, NULL);
- listRepPtr = ListRepPtr(resultObj);
- listRepPtr->elemCount = elemc;
- dataArray = &listRepPtr->elements;
+
+ /* Modify the internal rep in-place */
+ ListObjGetRep(resultObj, &listRep);
+ listRep.storePtr->numUsed = elemc;
+ dataArray = ListRepElementsBase(&listRep);
+ if (listRep.spanPtr) {
+ /* Future proofing */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
dataArray[j] = elemv[i];
@@ -2890,34 +3233,36 @@ Tcl_LreverseObjCmd(
int
Tcl_LsearchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
- int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
- int dataType, isIncreasing, lower, upper, offset;
+ int i, match, index, result=TCL_OK, listc, bisect;
+ int length, elemLen, start, groupSize, groupOffset, lower, upper;
+ int allocatedIndexVector = 0;
+ int dataType, isIncreasing;
Tcl_WideInt patWide, objWide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
- SortStrCmpFn_t strCmpFn = strcmp;
+ SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
- "-real", "-regexp", "-sorted", "-start",
+ "-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
- enum options {
+ enum lsearchoptions {
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
+ LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2937,7 +3282,9 @@ Tcl_LsearchObjCmd(
bisect = 0;
listPtr = NULL;
startPtr = NULL;
- offset = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ start = 0;
noCase = 0;
sortInfo.compareCmdPtr = NULL;
sortInfo.isIncreasing = 1;
@@ -2955,13 +3302,10 @@ Tcl_LsearchObjCmd(
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
- switch ((enum options) index) {
+ switch ((enum lsearchoptions) index) {
case LSEARCH_ALL: /* -all */
allMatches = 1;
break;
@@ -3022,6 +3366,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -3042,25 +3387,47 @@ Tcl_LsearchObjCmd(
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
- Tcl_IncrRefCount(startPtr);
}
+ Tcl_IncrRefCount(startPtr);
+ break;
+ case LSEARCH_STRIDE: /* -stride */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (groupSize < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 1", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADSTRIDE", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int j;
- if (sortInfo.indexc > 1) {
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
+ allocatedIndexVector = 0;
}
if (i > objc-4) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -3070,12 +3437,10 @@ Tcl_LsearchObjCmd(
*/
i++;
- if (TclListObjGetElements(interp, objv[i],
+ if (TclListObjGetElementsM(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch (sortInfo.indexc) {
case 0:
@@ -3087,6 +3452,8 @@ Tcl_LsearchObjCmd(
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
}
/*
@@ -3097,15 +3464,14 @@ Tcl_LsearchObjCmd(
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
- if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE,
- TCL_INDEX_AFTER, &encoded) != TCL_OK) {
+ if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
- if ((encoded == TCL_INDEX_BEFORE)
- || (encoded == TCL_INDEX_AFTER)) {
+ if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indices[j])));
+ "index \"%s\" out of range",
+ TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
@@ -3127,14 +3493,12 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && sortInfo.indexc==0) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (bisect && (allMatches || negatedMatch)) {
@@ -3142,7 +3506,8 @@ Tcl_LsearchObjCmd(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (mode == REGEXP) {
@@ -3168,9 +3533,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3181,26 +3543,66 @@ Tcl_LsearchObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
+ result = TclListObjGetElementsM(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
goto done;
}
/*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #351]
+ */
+
+ if (groupSize > 1) {
+ if (listc % groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
+ NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ 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 = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
+ if (groupOffset < 0 || groupOffset >= groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADINDEX", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
+ /*
* Get the user-specified start offset.
*/
if (startPtr) {
- result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
- Tcl_DecrRefCount(startPtr);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
- if (offset < 0) {
- offset = 0;
+ if (start == TCL_INDEX_NONE) {
+ start = TCL_INDEX_START;
}
/*
@@ -3208,16 +3610,22 @@ Tcl_LsearchObjCmd(
* "did not match anything at all" result straight away. [Bug 1374778]
*/
- if (offset > listc-1) {
- if (sortInfo.indexc > 1) {
- TclStackFree(interp, sortInfo.indexv);
- }
+ if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ TclNewIntObj(itemPtr, -1);
+ Tcl_SetObjResult(interp, itemPtr);
}
- return TCL_OK;
+ goto done;
+ }
+
+ /*
+ * If start points within a group, it points to the start of the group.
+ */
+
+ if (groupSize > 1) {
+ start -= (start % groupSize);
}
}
@@ -3240,7 +3648,7 @@ Tcl_LsearchObjCmd(
* 1844789]
*/
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+ TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
@@ -3253,7 +3661,7 @@ Tcl_LsearchObjCmd(
* 1844789]
*/
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+ TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
@@ -3276,18 +3684,23 @@ Tcl_LsearchObjCmd(
* sense in doing this when the match sense is inverted.
*/
- lower = offset - 1;
+ /*
+ * With -stride, lower, upper and i are kept as multiples of groupSize.
+ */
+
+ lower = start - groupSize;
upper = listc;
- while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
+ while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
+ i -= i % groupSize;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch ((enum datatypes) dataType) {
case ASCII:
@@ -3332,7 +3745,7 @@ Tcl_LsearchObjCmd(
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
- * To maintain consistancy with standard lsearch semantics, we
+ * To maintain consistency with standard lsearch semantics, we
* must find the leftmost occurrence of the pattern in the
* list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
@@ -3376,10 +3789,10 @@ Tcl_LsearchObjCmd(
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
- for (i = offset; i < listc; i++) {
+ for (i = start; i < listc; i += groupSize) {
match = 0;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
@@ -3388,7 +3801,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3406,8 +3819,7 @@ Tcl_LsearchObjCmd(
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
- match = (memcmp(bytes, patternBytes,
- (size_t) length) == 0);
+ match = (memcmp(bytes, patternBytes, length) == 0);
}
}
break;
@@ -3478,22 +3890,28 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo);
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else if (groupSize > 1) {
+ Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
+ groupSize, &listv[i]);
} else {
itemPtr = listv[i];
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
- Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (returnSubindices) {
int j;
- TclNewIntObj(itemPtr, i);
+ TclNewIndexObj(itemPtr, i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
- TclIndexDecode(sortInfo.indexv[j], listc)));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
+ Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
- Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i));
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
@@ -3508,14 +3926,17 @@ Tcl_LsearchObjCmd(
if (returnSubindices) {
int j;
- TclNewIntObj(itemPtr, index);
+ TclNewIndexObj(itemPtr, index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
- TclIndexDecode(sortInfo.indexv[j], listc)));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
+ Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_SetObjResult(interp, itemPtr);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, index);
+ Tcl_SetObjResult(interp, elObj);
}
} else if (index < 0) {
/*
@@ -3525,7 +3946,14 @@ Tcl_LsearchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
- Tcl_SetObjResult(interp, listv[index]);
+ if (returnSubindices) {
+ Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo));
+ } else if (groupSize > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
+ } else {
+ Tcl_SetObjResult(interp, listv[index]);
+ }
}
result = TCL_OK;
@@ -3534,7 +3962,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3559,7 +3990,7 @@ Tcl_LsearchObjCmd(
int
Tcl_LsetObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -3628,6 +4059,406 @@ Tcl_LsetObjCmd(
/*
*----------------------------------------------------------------------
*
+ * SequenceIdentifyArgument --
+ * (for [lseq] command)
+ *
+ * Given a Tcl_Obj, identify if it is a keyword or a number
+ *
+ * Return Value
+ * 0 - failure, unexpected value
+ * 1 - value is a number
+ * 2 - value is an operand keyword
+ * 3 - value is a by keyword
+ *
+ * The decoded value will be assigned to the appropriate
+ * pointer, if supplied.
+ */
+
+static SequenceDecoded
+SequenceIdentifyArgument(
+ Tcl_Interp *interp, /* for error reporting */
+ Tcl_Obj *argPtr, /* Argument to decode */
+ Tcl_Obj **numValuePtr, /* Return numeric value */
+ int *keywordIndexPtr) /* Return keyword enum */
+{
+ int status;
+ SequenceOperators opmode;
+ SequenceByMode bymode;
+ void *clientData;
+
+ status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr);
+ if (status == TCL_OK) {
+ if (numValuePtr) {
+ *numValuePtr = argPtr;
+ }
+ return NumericArg;
+ } else {
+ /* Check for an index expression */
+ long value;
+ double dvalue;
+ Tcl_Obj *exprValueObj;
+ int keyword;
+ Tcl_InterpState savedstate;
+ savedstate = Tcl_SaveInterpState(interp, status);
+ if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) {
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ exprValueObj = argPtr;
+ } else {
+ // Determine if expression is double or int
+ if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) {
+ keyword = TCL_NUMBER_INT;
+ exprValueObj = argPtr;
+ } else {
+ if (floor(dvalue) == dvalue) {
+ TclNewIntObj(exprValueObj, value);
+ keyword = TCL_NUMBER_INT;
+ } else {
+ TclNewDoubleObj(exprValueObj, dvalue);
+ keyword = TCL_NUMBER_DOUBLE;
+ }
+ }
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ if (numValuePtr) {
+ *numValuePtr = exprValueObj;
+ }
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = keyword ;// type of expression result
+ }
+ return NumericArg;
+ }
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
+ "range operation", 0, &opmode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = opmode;
+ }
+ return RangeKeywordArg;
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords,
+ "step keyword", 0, &bymode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = bymode;
+ }
+ return ByKeywordArg;
+ }
+ return NoneArg;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LseqObjCmd --
+ *
+ * This procedure is invoked to process the "lseq" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Enumerated possible argument patterns:
+ *
+ * 1:
+ * lseq n
+ * 2:
+ * lseq n n
+ * 3:
+ * lseq n n n
+ * lseq n 'to' n
+ * lseq n 'count' n
+ * lseq n 'by' n
+ * 4:
+ * lseq n 'to' n n
+ * lseq n n 'by' n
+ * lseq n 'count' n n
+ * 5:
+ * lseq n 'to' n 'by' n
+ * lseq n 'count' n 'by' n
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LseqObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_Obj *elementCount = NULL;
+ Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
+ Tcl_WideInt values[5];
+ Tcl_Obj *numValues[5];
+ Tcl_Obj *numberObj;
+ int status, keyword, useDoubles = 0;
+ Tcl_Obj *arithSeriesPtr;
+ SequenceOperators opmode;
+ SequenceDecoded decoded;
+ int i, arg_key = 0, value_i = 0;
+ // Default constants
+ Tcl_Obj *zero = Tcl_NewIntObj(0);
+ Tcl_Obj *one = Tcl_NewIntObj(1);
+
+ /*
+ * Create a decoding key by looping through the arguments and identify
+ * what kind of argument each one is. Encode each argument as a decimal
+ * digit.
+ */
+ if (objc > 6) {
+ /* Too many arguments */
+ arg_key=0;
+ } else for (i=1; i<objc; i++) {
+ arg_key = (arg_key * 10);
+ numValues[value_i] = NULL;
+ decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword);
+ switch (decoded) {
+
+ case NoneArg:
+ /*
+ * Unrecognizable argument
+ * Reproduce operation error message
+ */
+ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
+ "operation", 0, &opmode);
+ goto done;
+
+ case NumericArg:
+ arg_key += NumericArg;
+ numValues[value_i] = numberObj;
+ Tcl_IncrRefCount(numValues[value_i]);
+ values[value_i] = keyword; // This is the TCL_NUMBER_* value
+ useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE;
+ value_i++;
+ break;
+
+ case RangeKeywordArg:
+ arg_key += RangeKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ case ByKeywordArg:
+ arg_key += ByKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ default:
+ arg_key += 9; // Error state
+ value_i++;
+ break;
+ }
+ }
+
+ /*
+ * The key encoding defines a valid set of arguments, or indicates an
+ * error condition; process the values accordningly.
+ */
+ switch (arg_key) {
+
+/* No argument */
+ case 0:
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* range n */
+ case 1:
+ start = zero;
+ elementCount = numValues[0];
+ end = NULL;
+ step = one;
+ break;
+
+/* range n n */
+ case 11:
+ start = numValues[0];
+ end = numValues[1];
+ break;
+
+/* range n n n */
+ case 111:
+ start = numValues[0];
+ end = numValues[1];
+ step = numValues[2];
+ break;
+
+/* range n 'to' n */
+/* range n 'count' n */
+/* range n 'by' n */
+ case 121:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_BY:
+ start = zero;
+ elementCount = numValues[0];
+ step = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = one;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ }
+ break;
+
+/* range n 'to' n n */
+/* range n 'count' n n */
+ case 1211:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_BY:
+ /* Error case */
+ status = TCL_ERROR;
+ goto done;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* range n n 'by' n */
+ case 1121:
+ start = numValues[0];
+ end = numValues[1];
+ opmode = (SequenceOperators)values[2];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[3];
+ break;
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ case LSEQ_COUNT:
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* range n 'to' n 'by' n */
+/* range n 'count' n 'by' n */
+ case 12121:
+ start = numValues[0];
+ opmode = (SequenceOperators)values[3];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[4];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* Error cases: incomplete arguments */
+ case 12:
+ opmode = (SequenceOperators)values[1]; goto KeywordError; break;
+ case 112:
+ opmode = (SequenceOperators)values[2]; goto KeywordError; break;
+ case 1212:
+ opmode = (SequenceOperators)values[3]; goto KeywordError; break;
+ KeywordError:
+ status = TCL_ERROR;
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"to\" value."));
+ break;
+ case LSEQ_COUNT:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"count\" value."));
+ break;
+ case LSEQ_BY:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"by\" value."));
+ break;
+ }
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* All other argument errors */
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+
+ /*
+ * Success! Now lets create the series object.
+ */
+ status = TclNewArithSeriesObj(interp, &arithSeriesPtr,
+ useDoubles, start, end, step, elementCount);
+
+ if (status == TCL_OK) {
+ Tcl_SetObjResult(interp, arithSeriesPtr);
+ }
+
+ done:
+ // Free number arguments.
+ while (--value_i>=0) {
+ if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]);
+ }
+
+ // Free constants
+ Tcl_DecrRefCount(zero);
+ Tcl_DecrRefCount(one);
+
+ return status;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
@@ -3644,7 +4475,7 @@ Tcl_LsetObjCmd(
int
Tcl_LsortObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -3741,7 +4572,7 @@ Tcl_LsortObjCmd(
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- if (TclListObjGetElements(interp, objv[i+1], &sortindex,
+ if (TclListObjGetElementsM(interp, objv[i+1], &sortindex,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
@@ -3758,13 +4589,12 @@ Tcl_LsortObjCmd(
for (j=0 ; j<sortindex ; j++) {
int encoded = 0;
int result = TclIndexEncode(interp, indexv[j],
- TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded);
+ TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
- if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE)
- || (encoded == TCL_INDEX_AFTER))) {
+ if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indexv[j])));
+ "index \"%s\" out of range",
+ TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
@@ -3834,7 +4664,7 @@ Tcl_LsortObjCmd(
if (indexPtr) {
Tcl_Obj **indexv;
- TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ TclListObjGetElementsM(interp, indexPtr, &sortInfo.indexc, &indexv);
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
@@ -3850,7 +4680,8 @@ Tcl_LsortObjCmd(
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
- TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]);
+ TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &sortInfo.indexv[j]);
}
}
@@ -3893,8 +4724,13 @@ Tcl_LsortObjCmd(
sortInfo.compareCmdPtr = newCommandPtr;
}
- sortInfo.resultCode = TclListObjGetElements(interp, listObj,
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ sortInfo.resultCode = TclArithSeriesGetElements(interp,
+ listObj, &length, &listObjPtrs);
+ } else {
+ sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
+ }
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
@@ -3994,7 +4830,7 @@ Tcl_LsortObjCmd(
goto done;
}
- for (i=0; i < length; i++){
+ for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
@@ -4077,18 +4913,18 @@ Tcl_LsortObjCmd(
*/
if (sortInfo.resultCode == TCL_OK) {
- List *listRepPtr;
+ ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
- listRepPtr = ListRepPtr(resultPtr);
- newArray = &listRepPtr->elements;
+ ListObjGetRep(resultPtr, &listRep);
+ newArray = ListRepElementsBase(&listRep);
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
- TclNewIntObj(objPtr, idx + j - groupOffset);
+ TclNewIndexObj(objPtr, idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
@@ -4100,7 +4936,7 @@ Tcl_LsortObjCmd(
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
- TclNewIntObj(objPtr, elementPtr->payload.index);
+ TclNewIndexObj(objPtr, elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -4111,7 +4947,11 @@ Tcl_LsortObjCmd(
Tcl_IncrRefCount(objPtr);
}
}
- listRepPtr->elemCount = i;
+ listRep.storePtr->numUsed = i;
+ if (listRep.spanPtr) {
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
Tcl_SetObjResult(interp, resultPtr);
}
@@ -4137,6 +4977,123 @@ Tcl_LsortObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LeditObjCmd --
+ *
+ * This procedure is invoked to process the "ledit" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LeditObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument values. */
+{
+ Tcl_Obj *listPtr; /* Pointer to the list being altered. */
+ Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
+ int createdNewObj;
+ int result;
+ int first;
+ int last;
+ int listLen;
+ int numToDelete;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar first last ?element ...?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * TODO - refactor the index extraction into a common function shared
+ * by Tcl_{Lrange,Lreplace,Ledit}ObjCmd
+ */
+
+ result = TclListObjLengthM(interp, listPtr, &listLen);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (first == TCL_INDEX_NONE) {
+ first = 0;
+ } else if (first > listLen) {
+ first = listLen;
+ }
+
+ if (last >= listLen) {
+ last = listLen - 1;
+ }
+ if (first <= last) {
+ numToDelete = last - first + 1;
+ } else {
+ numToDelete = 0;
+ }
+
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ createdNewObj = 1;
+ } else {
+ createdNewObj = 0;
+ }
+
+ result =
+ Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4);
+ if (result != TCL_OK) {
+ if (createdNewObj) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ return result;
+ }
+
+ /*
+ * Tcl_ObjSetVar2 mau return a value different from listPtr in the
+ * presence of traces etc.. Note that finalValuePtr will always have a
+ * reference count of at least 1 corresponding to the reference from the
+ * var. If it is same as listPtr, then ref count will be at least 2
+ * since we are incr'ing the latter below (safer when calling
+ * Tcl_ObjSetVar2 which can release it in some cases). Note that we
+ * leave the incrref of listPtr this late because we want to pass it as
+ * unshared to Tcl_ListObjReplace above if possible.
+ */
+ Tcl_IncrRefCount(listPtr);
+ finalValuePtr =
+ Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */
+ if (finalValuePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, finalValuePtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* MergeLists -
*
* This procedure combines two sorted lists of SortElement structures
@@ -4264,7 +5221,7 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
@@ -4310,10 +5267,10 @@ SortCompare(
* Replace them and evaluate the result.
*/
- TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+ TclListObjLengthM(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
- TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+ TclListObjGetElementsM(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
@@ -4450,8 +5407,8 @@ DictionaryCompare(
* other interesting punctuations occur).
*/
- uniLeftLower = TclUCS4ToLower(uniLeft);
- uniRightLower = TclUCS4ToLower(uniRight);
+ uniLeftLower = Tcl_UniCharToLower(uniLeft);
+ uniRightLower = Tcl_UniCharToLower(uniRight);
} else {
diff = UCHAR(*left) - UCHAR(*right);
break;
@@ -4523,7 +5480,7 @@ SelectObjFromSublist(
int listLen, index;
Tcl_Obj *currentObj;
- if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4536,9 +5493,16 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
- "element %d missing from sublist \"%s\"",
- index, TclGetString(objPtr)));
+ if (index == (int)TCL_INDEX_NONE) {
+ index = TCL_INDEX_END - infoPtr->indexv[i];
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element end-%d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ } else {
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ }
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a97f309..817416a 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -6,11 +6,11 @@
* 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.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2003-2009 Donal K. Fellows.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 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.
@@ -82,7 +82,7 @@ const char tclDefaultTrimSet[] =
int
Tcl_PwdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -122,7 +122,7 @@ Tcl_PwdObjCmd(
int
Tcl_RegexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -137,7 +137,7 @@ Tcl_RegexpObjCmd(
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
};
- enum options {
+ enum regexpoptions {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
@@ -162,7 +162,7 @@ Tcl_RegexpObjCmd(
&index) != TCL_OK) {
goto optionError;
}
- switch ((enum options) index) {
+ switch ((enum regexpoptions) index) {
case REGEXP_ALL:
all = 1;
break;
@@ -195,7 +195,7 @@ Tcl_RegexpObjCmd(
if (++i >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[i], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -256,10 +256,10 @@ Tcl_RegexpObjCmd(
*/
objPtr = objv[1];
- stringLength = Tcl_GetCharLength(objPtr);
+ stringLength = TclGetCharLength(objPtr);
if (startIndex) {
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -310,7 +310,7 @@ Tcl_RegexpObjCmd(
eflags = 0;
} else if (offset > stringLength) {
eflags = TCL_REG_NOTBOL;
- } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
+ } else if (TclGetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
@@ -324,7 +324,7 @@ Tcl_RegexpObjCmd(
if (match == 0) {
/*
- * We want to set the value of the intepreter result only when
+ * We want to set the value of the interpreter result only when
* this is the first time through the loop.
*/
@@ -336,7 +336,7 @@ Tcl_RegexpObjCmd(
*/
if (!doinline) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -385,17 +385,17 @@ Tcl_RegexpObjCmd(
end--;
}
} else {
- start = -1;
- end = -1;
+ start = TCL_INDEX_NONE;
+ end = TCL_INDEX_NONE;
}
- objs[0] = Tcl_NewLongObj(start);
- objs[1] = Tcl_NewLongObj(end);
+ TclNewIndexObj(objs[0], start);
+ TclNewIndexObj(objs[1], end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if ((i <= info.nsubs) && (info.matches[i].end > 0)) {
- newPtr = Tcl_GetRange(objPtr,
+ newPtr = TclGetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
@@ -458,7 +458,7 @@ Tcl_RegexpObjCmd(
if (doinline) {
Tcl_SetObjResult(interp, resultPtr);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1));
}
return TCL_OK;
}
@@ -482,32 +482,33 @@ Tcl_RegexpObjCmd(
int
Tcl_RegsubObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
- int start, end, subStart, subEnd, match;
+ int start, end, subStart, subEnd, match, command, numParts;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
- Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
+ Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
- "-all", "-nocase", "-expanded",
- "-line", "-linestop", "-lineanchor", "-start",
+ "-all", "-command", "-expanded", "-line",
+ "-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
- enum options {
- REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
- REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
+ enum regsubobjoptions {
+ REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
+ REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
+ command = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
@@ -522,13 +523,16 @@ Tcl_RegsubObjCmd(
TCL_EXACT, &index) != TCL_OK) {
goto optionError;
}
- switch ((enum options) index) {
+ switch ((enum regsubobjoptions) index) {
case REGSUB_ALL:
all = 1;
break;
case REGSUB_NOCASE:
cflags |= TCL_REG_NOCASE;
break;
+ case REGSUB_COMMAND:
+ command = 1;
+ break;
case REGSUB_EXPANDED:
cflags |= TCL_REG_EXPANDED;
break;
@@ -546,7 +550,7 @@ Tcl_RegsubObjCmd(
if (++idx >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[idx], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -577,16 +581,16 @@ Tcl_RegsubObjCmd(
objv += idx;
if (startIndex) {
- int stringLength = Tcl_GetCharLength(objv[1]);
+ int stringLength = TclGetCharLength(objv[1]);
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
}
}
- if (all && (offset == 0)
+ if (all && (offset == 0) && (command == 0)
&& (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
&& (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
@@ -594,17 +598,17 @@ Tcl_RegsubObjCmd(
* slightly modified version of the one pair STR_MAP code.
*/
- int slen, nocase;
+ int slen, nocase, wsrclc;
int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long);
- Tcl_UniChar *p, wsrclc;
+ Tcl_UniChar *p;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
- strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
+ strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp;
- wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
- wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
- wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
+ wsrc = TclGetUnicodeFromObj_(objv[0], &slen);
+ wstring = TclGetUnicodeFromObj_(objv[1], &wlen);
+ wsubspec = TclGetUnicodeFromObj_(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
@@ -615,11 +619,11 @@ Tcl_RegsubObjCmd(
*/
if (wstring < wend) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
for (; wstring < wend; wstring++) {
- Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
- Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
+ TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ TclAppendUnicodeToObj(resultPtr, wstring, 1);
numMatches++;
}
wlen = 0;
@@ -632,18 +636,18 @@ Tcl_RegsubObjCmd(
(slen==1 || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
- Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
+ TclAppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
} else {
p += slen;
}
wstring = p - 1;
- Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen);
numMatches++;
}
}
@@ -662,6 +666,28 @@ Tcl_RegsubObjCmd(
return TCL_ERROR;
}
+ if (command) {
+ /*
+ * In command-prefix mode, we require that the third non-option
+ * argument be a list, so we enforce that here. Afterwards, we fetch
+ * the RE compilation again in case objv[0] and objv[2] are the same
+ * object. (If they aren't, that's cheap to do.)
+ */
+
+ if (TclListObjLengthM(interp, objv[2], &numParts) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (numParts < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command prefix must be a list of at least one element",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB",
+ "CMDEMPTY", NULL);
+ return TCL_ERROR;
+ }
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ }
+
/*
* Make sure to avoid problems where the objects are shared. This can
* cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
@@ -673,13 +699,15 @@ Tcl_RegsubObjCmd(
} else {
objPtr = objv[1];
}
- wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
+ wstring = TclGetUnicodeFromObj_(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
- wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ if (!command) {
+ wsubspec = TclGetUnicodeFromObj_(subPtr, &wsublen);
+ }
result = TCL_OK;
@@ -714,7 +742,7 @@ Tcl_RegsubObjCmd(
break;
}
if (numMatches == 0) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
@@ -722,7 +750,7 @@ Tcl_RegsubObjCmd(
* specified.
*/
- Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
+ TclAppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
@@ -735,7 +763,91 @@ Tcl_RegsubObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
start = info.matches[0].start;
end = info.matches[0].end;
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, start);
+
+ /*
+ * In command-prefix mode, the substitutions are added as quoted
+ * arguments to the subSpec to form a command, that is then executed
+ * and the result used as the string to substitute in. Actually,
+ * everything is passed through Tcl_EvalObjv, as that's much faster.
+ */
+
+ if (command) {
+ Tcl_Obj **args = NULL, **parts;
+ int numArgs;
+
+ TclListObjGetElementsM(interp, subPtr, &numParts, &parts);
+ numArgs = numParts + info.nsubs + 1;
+ args = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * numArgs);
+ memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
+
+ for (idx = 0 ; idx <= info.nsubs ; idx++) {
+ subStart = info.matches[idx].start;
+ subEnd = info.matches[idx].end;
+ if ((subStart >= 0) && (subEnd >= 0)) {
+ args[idx + numParts] = TclNewUnicodeObj(
+ wstring + offset + subStart, subEnd - subStart);
+ } else {
+ TclNewObj(args[idx + numParts]);
+ }
+ Tcl_IncrRefCount(args[idx + numParts]);
+ }
+
+ /*
+ * At this point, we're locally holding the references to the
+ * argument words we added for this time round the loop, and the
+ * subPtr is holding the references to the words that the user
+ * supplied directly. None are zero-refcount, which is important
+ * because Tcl_EvalObjv is "hairy monster" in terms of refcount
+ * handling, being able to optionally add references to any of its
+ * argument words. We'll drop the local refs immediately
+ * afterwards; subPtr is handled in the main exit stanza.
+ */
+
+ result = Tcl_EvalObjv(interp, numArgs, args, 0);
+ for (idx = 0 ; idx <= info.nsubs ; idx++) {
+ TclDecrRefCount(args[idx + numParts]);
+ }
+ ckfree(args);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s substitution computation script)",
+ options[REGSUB_COMMAND]));
+ }
+ goto done;
+ }
+
+ Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
+ Tcl_ResetResult(interp);
+
+ /*
+ * Refetch the unicode, in case the representation was smashed by
+ * the user code.
+ */
+
+ wstring = TclGetUnicodeFromObj_(objPtr, &wlen);
+
+ offset += end;
+ if (end == 0 || start == end) {
+ /*
+ * Always consume at least one character of the input string
+ * in order to prevent infinite loops, even when we
+ * technically matched the empty string; we must not match
+ * again at the same spot.
+ */
+
+ if (offset < wlen) {
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ }
+ offset++;
+ }
+ if (all) {
+ continue;
+ } else {
+ break;
+ }
+ }
/*
* Append the subSpec argument to the variable, making appropriate
@@ -755,7 +867,7 @@ Tcl_RegsubObjCmd(
idx = ch - '0';
} else if ((ch == '\\') || (ch == '&')) {
*wsrc = ch;
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ TclAppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar + 1);
*wsrc = '\\';
wfirstChar = wsrc + 2;
@@ -769,7 +881,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ TclAppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar);
}
@@ -777,7 +889,7 @@ Tcl_RegsubObjCmd(
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
- Tcl_AppendUnicodeToObj(resultPtr,
+ TclAppendUnicodeToObj(resultPtr,
wstring + offset + subStart, subEnd - subStart);
}
}
@@ -789,7 +901,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
+ TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
@@ -799,7 +911,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
@@ -811,7 +923,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
@@ -836,7 +948,7 @@ Tcl_RegsubObjCmd(
resultPtr = objv[1];
Tcl_IncrRefCount(resultPtr);
} else if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
if (objc == 4) {
if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr,
@@ -848,7 +960,7 @@ Tcl_RegsubObjCmd(
* holding the number of matches.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches));
}
} else {
/*
@@ -890,7 +1002,7 @@ Tcl_RegsubObjCmd(
int
Tcl_RenameObjCmd(
- ClientData dummy, /* Arbitrary value passed to the command. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -926,7 +1038,7 @@ Tcl_RenameObjCmd(
int
Tcl_ReturnObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -973,25 +1085,28 @@ Tcl_ReturnObjCmd(
int
Tcl_SourceObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
+ int result;
+ void **pkgFiles = NULL;
+ void *names = NULL;
- if (objc != 2 && objc !=4) {
+ if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
return TCL_ERROR;
}
@@ -1009,9 +1124,30 @@ TclNRSourceObjCmd(
return TCL_ERROR;
}
encodingName = TclGetString(objv[2]);
- }
+ } else if (objc == 3) {
+ /* Handle undocumented -nopkg option. This should only be
+ * used by the internal ::tcl::Pkg::source utility function. */
+ static const char *const nopkgoptions[] = {
+ "-nopkg", NULL
+ };
+ int index;
- return TclNREvalFile(interp, fileName, encodingName);
+ if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
+ "option", TCL_EXACT, &index)) {
+ return TCL_ERROR;
+ }
+ pkgFiles = (void **)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ /* Make sure that during the following TclNREvalFile no filenames
+ * are recorded for inclusion in the "package files" command */
+ names = *pkgFiles;
+ *pkgFiles = NULL;
+ }
+ result = TclNREvalFile(interp, fileName, encodingName);
+ if (pkgFiles) {
+ /* restore "tclPkgFiles" assocdata to how it was. */
+ *pkgFiles = names;
+ }
+ return result;
}
/*
@@ -1033,12 +1169,12 @@ TclNRSourceObjCmd(
int
Tcl_SplitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
+ int ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
@@ -1081,10 +1217,8 @@ Tcl_SplitObjCmd(
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
- int ucs4;
-
- len = TclUtfToUCS4(stringPtr, &ucs4);
- hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ucs4), &isNew);
+ len = TclUtfToUCS4(stringPtr, &ch);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1094,14 +1228,14 @@ Tcl_SplitObjCmd(
Tcl_SetHashValue(hPtr, objPtr);
} else {
- objPtr = Tcl_GetHashValue(hPtr);
+ objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
- char *p;
+ const char *p;
/*
* Handle the special case of splitting on a single character. This is
@@ -1119,7 +1253,7 @@ Tcl_SplitObjCmd(
} else {
const char *element, *p, *splitEnd;
int splitLen;
- Tcl_UniChar splitChar = 0;
+ int splitChar;
/*
* Normal case: split on any of a given set of characters. Discard
@@ -1129,9 +1263,9 @@ Tcl_SplitObjCmd(
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
- len = TclUtfToUniChar(stringPtr, &ch);
+ len = TclUtfToUCS4(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
- splitLen = TclUtfToUniChar(p, &splitChar);
+ splitLen = TclUtfToUCS4(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
@@ -1168,13 +1302,12 @@ Tcl_SplitObjCmd(
static int
StringFirstCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr;
- int match, start, needleLen, haystackLen;
+ int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1182,82 +1315,14 @@ StringFirstCmd(
return TCL_ERROR;
}
- /*
- * We are searching haystackStr for the sequence needleStr.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to fast forward to that
- * point in the string before we think about a match.
- */
+ int size = TclGetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
-
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start >= haystackLen) {
- goto str_first_done;
- } else if (start > 0) {
- haystackStr += start;
- haystackLen -= start;
- } else if (start < 0) {
- /*
- * Invalid start index mapped to string start; Bug #423581
- */
-
- start = 0;
- }
}
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- Tcl_UniChar *p, *end;
-
- end = haystackStr + haystackLen - needleLen + 1;
- for (p = haystackStr; p < end; p++) {
- /*
- * Scan forward to find the first character.
- */
-
- if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p,
- (unsigned long) needleLen) == 0)) {
- match = p - haystackStr;
- break;
- }
- }
- }
-
- /*
- * Compute the character index of the matching string by counting the
- * number of characters before the match.
- */
-
- if ((match != -1) && (objc == 4)) {
- match += start;
- }
-
- str_first_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
return TCL_OK;
}
@@ -1281,81 +1346,27 @@ StringFirstCmd(
static int
StringLastCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr, *p;
- int match, start, needleLen, haystackLen;
+ int last = INT_MAX - 1;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "needleString haystackString ?startIndex?");
+ "needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
- /*
- * We are searching haystackString for the sequence needleString.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to restrict the string
- * range to that char index in the string
- */
+ int size = TclGetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
-
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start < 0) {
- goto str_last_done;
- } else if (start < haystackLen) {
- p = haystackStr + start + 1 - needleLen;
- } else {
- p = haystackStr + haystackLen - needleLen;
- }
- } else {
- p = haystackStr + haystackLen - needleLen;
- }
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- for (; p >= haystackStr; p--) {
- /*
- * Scan backwards to find the first character.
- */
-
- if ((*p == *needleStr) && !memcmp(needleStr, p,
- sizeof(Tcl_UniChar) * (size_t)needleLen)) {
- match = p - haystackStr;
- break;
- }
- }
}
-
- str_last_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
return TCL_OK;
}
@@ -1379,7 +1390,7 @@ StringLastCmd(
static int
StringIndexCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1392,16 +1403,20 @@ StringIndexCmd(
}
/*
- * Get the char length to calulate what 'end' means.
+ * Get the char length to calculate what 'end' means.
*/
- length = Tcl_GetCharLength(objv[1]);
+ length = TclGetCharLength(objv[1]);
if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length)) {
- int ch = TclGetUCS4(objv[1], index);
+ int ch = TclGetUniChar(objv[1], index);
+
+ if (ch == -1) {
+ return TCL_OK;
+ }
/*
* If we have a ByteArray object, we're careful to generate a new
@@ -1413,9 +1428,12 @@ StringIndexCmd(
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
- char buf[8] = "";
+ char buf[4] = "";
- length = TclUCS4ToUtf(ch, buf);
+ length = Tcl_UniCharToUtf(ch, buf);
+ if ((ch >= 0xD800) && (length < 3)) {
+ length += Tcl_UniCharToUtf(-1, buf + length);
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
}
}
@@ -1425,6 +1443,63 @@ StringIndexCmd(
/*
*----------------------------------------------------------------------
*
+ * StringInsertCmd --
+ *
+ * This procedure is invoked to process the "string insert" Tcl command.
+ * 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.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+StringInsertCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter */
+ int objc, /* Number of arguments */
+ Tcl_Obj *const objv[]) /* Argument objects */
+{
+ int length; /* String length */
+ int index; /* Insert index */
+ Tcl_Obj *outObj; /* Output object */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
+ return TCL_ERROR;
+ }
+
+ length = TclGetCharLength(objv[1]);
+ if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (index < 0) {
+ index = 0;
+ }
+ if (index > length) {
+ index = length;
+ }
+
+ outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
+ TCL_STRING_IN_PLACE);
+
+ if (outObj != NULL) {
+ Tcl_SetObjResult(interp, outObj);
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* StringIsCmd --
*
* This procedure is invoked to process the "string is" Tcl command. See
@@ -1442,7 +1517,7 @@ StringIndexCmd(
static int
StringIsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1455,24 +1530,24 @@ StringIsCmd(
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
- enum isClasses {
+ enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- 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_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, 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_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
};
- enum isOptions {
+ enum isOptionsEnum {
OPT_STRICT, OPT_FAILIDX
};
@@ -1494,7 +1569,7 @@ StringIsCmd(
&idx2) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum isOptions) idx2) {
+ switch ((enum isOptionsEnum) idx2) {
case OPT_STRICT:
strict = 1;
break;
@@ -1523,7 +1598,7 @@ StringIsCmd(
* When entering here, result == 1 and failat == 0.
*/
- switch ((enum isClasses) index) {
+ switch ((enum isClassesEnum) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
@@ -1536,7 +1611,7 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if ((objPtr->typePtr != &tclBooleanType)
+ if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
@@ -1544,26 +1619,71 @@ StringIsCmd(
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
- } else if (((index == STR_IS_TRUE) &&
- objPtr->internalRep.longValue == 0)
- || ((index == STR_IS_FALSE) &&
- objPtr->internalRep.longValue != 0)) {
- result = 0;
+ } else if (index != STR_IS_BOOL) {
+ TclGetBooleanFromObj(NULL, objPtr, &i);
+ if ((index == STR_IS_TRUE) ^ i) {
+ result = 0;
+ }
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
+ case STR_IS_DICT: {
+ int dresult, dsize;
+
+ dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
+ Tcl_ResetResult(interp);
+ result = (dresult == TCL_OK) ? 1 : 0;
+ if (dresult != TCL_OK && failVarObj != NULL) {
+ /*
+ * Need to figure out where the list parsing failed, which is
+ * fairly expensive. This is adapted from the core of
+ * SetDictFromAny().
+ */
+
+ const char *elemStart, *nextElem;
+ int lenRemain, elemSize;
+ const char *p;
+
+ string1 = TclGetStringFromObj(objPtr, &length1);
+ end = string1 + length1;
+ failat = -1;
+ for (p=string1, lenRemain=length1; lenRemain > 0;
+ p=nextElem, lenRemain=end-nextElem) {
+ if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
+ &elemStart, &nextElem, &elemSize, NULL)) {
+ Tcl_Obj *tmpStr;
+
+ /*
+ * This is the simplest way of getting the number of
+ * characters parsed. Note that this is not the same as
+ * the number of bytes when parsing strings with non-ASCII
+ * characters in them.
+ *
+ * Skip leading spaces first. This is only really an issue
+ * if it is the first "element" that has the failure.
+ */
+
+ while (TclIsSpaceProc(*p)) {
+ p++;
+ }
+ TclNewStringObj(tmpStr, string1, p-string1);
+ failat = TclGetCharLength(tmpStr);
+ TclDecrRefCount(tmpStr);
+ break;
+ }
+ }
+ }
+ break;
+ }
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
- if ((objPtr->typePtr == &tclDoubleType) ||
- (objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
- (objPtr->typePtr == &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, &tclDoubleType) ||
+ TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1582,7 +1702,7 @@ StringIsCmd(
failat = stop - string1;
if (stop < end) {
result = 0;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
}
break;
@@ -1591,16 +1711,9 @@ StringIsCmd(
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) {
- break;
- }
- goto failedIntParse;
case STR_IS_ENTIER:
- if ((objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
- (objPtr->typePtr == &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1629,7 +1742,7 @@ StringIsCmd(
result = 0;
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1645,7 +1758,6 @@ StringIsCmd(
break;
}
- failedIntParse:
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
@@ -1683,7 +1795,7 @@ StringIsCmd(
*/
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1699,7 +1811,7 @@ StringIsCmd(
* well-formed lists.
*/
- if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) {
+ if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length2)) {
break;
}
@@ -1737,7 +1849,7 @@ StringIsCmd(
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
- failat = Tcl_GetCharLength(tmpStr);
+ failat = TclGetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
@@ -1760,6 +1872,9 @@ StringIsCmd(
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
+ case STR_IS_UNICODE:
+ chcomp = Tcl_UniCharIsUnicode;
+ break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
@@ -1794,10 +1909,11 @@ StringIsCmd(
*/
str_is_done:
- if ((result == 0) && (failVarObj != NULL) &&
- Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
- TCL_LEAVE_ERR_MSG) == NULL) {
- return TCL_ERROR;
+ if ((result == 0) && (failVarObj != NULL)) {
+ TclNewIndexObj(objPtr, failat);
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
@@ -1814,7 +1930,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
@@ -1837,7 +1953,7 @@ UniCharIsHexDigit(
static int
StringMapCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1870,10 +1986,11 @@ StringMapCmd(
/*
* This test is tricky, but has to be that way or you get other strange
- * inconsistencies (see test string-10.20 for illustration why!)
+ * inconsistencies (see test string-10.20.1 for illustration why!)
*/
- if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){
+ if (!TclHasStringRep(objv[objc-2])
+ && TclHasInternalRep(objv[objc-2], &tclDictType)) {
int i, done;
Tcl_DictSearch search;
@@ -1900,7 +2017,7 @@ StringMapCmd(
* adapt this code...
*/
- mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
+ mapElemv = (Tcl_Obj **)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) {
@@ -1908,7 +2025,7 @@ StringMapCmd(
}
Tcl_DictObjDone(&search);
} else {
- if (TclListObjGetElements(interp, objv[objc-2], &mapElemc,
+ if (TclListObjGetElementsM(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1943,7 +2060,7 @@ StringMapCmd(
} else {
sourceObj = objv[objc-1];
}
- ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
+ ustring1 = TclGetUnicodeFromObj_(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now.
@@ -1953,13 +2070,13 @@ StringMapCmd(
}
end = ustring1 + length1;
- strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
+ strCmpFn = (nocase ? TclUniCharNcasecmp : TclUniCharNcmp);
/*
* Force result to be Unicode
*/
- resultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ resultPtr = TclNewUnicodeObj(ustring1, 0);
if (mapElemc == 2) {
/*
@@ -1969,10 +2086,10 @@ StringMapCmd(
* larger strings.
*/
- int mapLen;
- Tcl_UniChar *mapString, u2lc;
+ int mapLen, u2lc;
+ Tcl_UniChar *mapString;
- ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+ ustring2 = TclGetUnicodeFromObj_(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/*
@@ -1981,7 +2098,7 @@ StringMapCmd(
ustring1 = end;
} else {
- mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
+ mapString = TclGetUnicodeFromObj_(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
@@ -1989,20 +2106,20 @@ StringMapCmd(
(length2==1 || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
- Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
+ TclAppendUnicodeToObj(resultPtr, mapString, mapLen);
}
}
}
} else {
- Tcl_UniChar **mapStrings, *u2lc = NULL;
- int *mapLens;
+ Tcl_UniChar **mapStrings;
+ int *mapLens, *u2lc = NULL;
/*
* Precompute pointers to the unicode string and length. This saves us
@@ -2011,13 +2128,13 @@ StringMapCmd(
* case.
*/
- mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
- mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
+ mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
+ mapLens = (int *)TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
if (nocase) {
- u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar));
+ u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
}
for (index = 0; index < mapElemc; index++) {
- mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
+ mapStrings[index] = TclGetUnicodeFromObj_(mapElemv[index],
mapLens+index);
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
@@ -2041,7 +2158,7 @@ StringMapCmd(
* Put the skipped chars onto the result first.
*/
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
@@ -2057,7 +2174,7 @@ StringMapCmd(
* Append the map value to the unicode string.
*/
- Tcl_AppendUnicodeToObj(resultPtr,
+ TclAppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
@@ -2074,7 +2191,7 @@ StringMapCmd(
* Put the rest of the unmapped chars onto result.
*/
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
Tcl_SetObjResult(interp, resultPtr);
done:
@@ -2107,7 +2224,7 @@ StringMapCmd(
static int
StringMatchCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2159,7 +2276,7 @@ StringMatchCmd(
static int
StringRangeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2176,21 +2293,15 @@ StringRangeCmd(
* 'end' refers to the last character, not one past it.
*/
- length = Tcl_GetCharLength(objv[1]) - 1;
+ length = TclGetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) {
return TCL_ERROR;
}
- if (first < 0) {
- first = 0;
- }
- if (last >= length) {
- last = length;
- }
- if (last >= first) {
- Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
+ if (last >= 0) {
+ Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last));
}
return TCL_OK;
}
@@ -2215,14 +2326,12 @@ StringRangeCmd(
static int
StringReptCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *string1;
- char *string2;
- int count, index, length1, length2;
+ int count;
Tcl_Obj *resultPtr;
if (objc != 3) {
@@ -2240,71 +2349,17 @@ StringReptCmd(
if (count == 1) {
Tcl_SetObjResult(interp, objv[1]);
- goto done;
+ return TCL_OK;
} else if (count < 1) {
- goto done;
- }
- string1 = TclGetStringFromObj(objv[1], &length1);
- if (length1 <= 0) {
- goto done;
- }
-
- /*
- * Only build up a string that has data. Instead of building it up with
- * repeated appends, we just allocate the necessary space once and copy
- * the string value in.
- *
- * We have to worry about overflow [Bugs 714106, 2561746].
- * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX.
- * We need to keep 2 <= length2 <= INT_MAX.
- */
-
- if (count > INT_MAX/length1) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "result exceeds max size for a Tcl value (%d bytes)",
- INT_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- return TCL_ERROR;
+ return TCL_OK;
}
- length2 = length1 * count;
- /*
- * Include space for the NUL.
- */
-
- string2 = attemptckalloc(length2 + 1);
- if (string2 == NULL) {
- /*
- * Alloc failed. Note that in this case we try to do an error message
- * since this is a case that's most likely when the alloc is large and
- * that's easy to do with this API. Note that if we fail allocating a
- * short string, this will likely keel over too (and fatally).
- */
-
- 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++) {
- memcpy(string2 + (length1 * index), string1, length1);
+ resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE);
+ if (resultPtr) {
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
}
- string2[length2] = '\0';
-
- /*
- * We have to directly assign this instead of using Tcl_SetStringObj (and
- * indirectly TclInitStringRep) because that makes another copy of the
- * data.
- */
-
- TclNewObj(resultPtr);
- resultPtr->bytes = string2;
- resultPtr->length = length2;
- Tcl_SetObjResult(interp, resultPtr);
-
- done:
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -2327,12 +2382,11 @@ StringReptCmd(
static int
StringRplcCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring;
int first, last, length, end;
if (objc < 4 || objc > 5) {
@@ -2340,19 +2394,20 @@ StringRplcCmd(
return TCL_ERROR;
}
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
+ length = TclGetCharLength(objv[1]);
end = length - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
- TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){
+ TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
/*
- * The following test screens out most empty substrings as
- * candidates for replacement. When they are detected, no
- * replacement is done, and the result is the original string,
+ * The following test screens out most empty substrings as candidates for
+ * replacement. When they are detected, no replacement is done, and the
+ * result is the original string.
*/
+
if ((last < 0) || /* Range ends before start of string */
(first > end) || /* Range begins after end of string */
(last < first)) { /* Range begins after it starts */
@@ -2362,30 +2417,22 @@ StringRplcCmd(
* have (first <= end < 0 <= last) and an empty string is permitted
* to be replaced.
*/
+
Tcl_SetObjResult(interp, objv[1]);
} else {
Tcl_Obj *resultPtr;
- /*
- * We are re-fetching in case the string argument is same value as
- * an index argument, and shimmering cost us our ustring.
- */
-
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
- end = length-1;
-
if (first < 0) {
first = 0;
}
-
- resultPtr = Tcl_NewUnicodeObj(ustring, first);
- if (objc == 5) {
- Tcl_AppendObjToObj(resultPtr, objv[4]);
- }
- if (last < end) {
- Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1,
- end - last);
+ if (last > end) {
+ last = end;
}
+
+ resultPtr = TclStringReplace(interp, objv[1], first,
+ last + 1 - first, (objc == 5) ? objv[4] : NULL,
+ TCL_STRING_IN_PLACE);
+
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
@@ -2411,7 +2458,7 @@ StringRplcCmd(
static int
StringRevCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2421,7 +2468,7 @@ StringRevCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclStringReverse(objv[1]));
+ Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE));
return TCL_OK;
}
@@ -2431,9 +2478,7 @@ StringRevCmd(
* StringStartCmd --
*
* This procedure is invoked to process the "string wordstart" Tcl
- * command. See the user documentation for details on what it does. Note
- * that this command only functions correctly on properly formed Tcl UTF
- * strings.
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -2446,46 +2491,45 @@ StringRevCmd(
static int
StringStartCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
- const char *p, *string;
- int cur, index, length, numChars;
+ int ch;
+ const Tcl_UniChar *p, *string;
+ int cur, index, length;
+ Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- numChars = Tcl_NumUtfChars(string, length);
- if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
+ string = TclGetUnicodeFromObj_(objv[1], &length);
+ if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- if (index >= numChars) {
- index = numChars - 1;
+ if (index >= length) {
+ index = length - 1;
}
cur = 0;
if (index > 0) {
- p = Tcl_UtfAtIndex(string, index);
+ p = &string[index];
- TclUtfToUniChar(p, &ch);
+ (void)TclUniCharToUCS4(p, &ch);
for (cur = index; cur >= 0; cur--) {
int delta = 0;
- const char *next;
+ const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
- next = TclUtfPrev(p, string);
+ next = TclUCS4Prev(p, string);
do {
next += delta;
- delta = TclUtfToUniChar(next, &ch);
+ delta = TclUniCharToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
@@ -2493,7 +2537,8 @@ StringStartCmd(
cur += 1;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ TclNewIndexObj(obj, cur);
+ Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -2503,8 +2548,7 @@ StringStartCmd(
* StringEndCmd --
*
* This procedure is invoked to process the "string wordend" Tcl command.
- * See the user documentation for details on what it does. Note that this
- * command only functions correctly on properly formed Tcl UTF strings.
+ * See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -2517,34 +2561,33 @@ StringStartCmd(
static int
StringEndCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
- const char *p, *end, *string;
- int cur, index, length, numChars;
+ int ch;
+ const Tcl_UniChar *p, *end, *string;
+ int cur, index, length;
+ Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- numChars = Tcl_NumUtfChars(string, length);
- if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
+ string = TclGetUnicodeFromObj_(objv[1], &length);
+ if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
if (index < 0) {
index = 0;
}
- if (index < numChars) {
- p = Tcl_UtfAtIndex(string, index);
+ if (index < length) {
+ p = &string[index];
end = string+length;
for (cur = index; p < end; cur++) {
- p += TclUtfToUniChar(p, &ch);
+ p += TclUniCharToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
@@ -2553,9 +2596,10 @@ StringEndCmd(
cur++;
}
} else {
- cur = numChars;
+ cur = length;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ TclNewIndexObj(obj, cur);
+ Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -2579,7 +2623,7 @@ StringEndCmd(
static int
StringEqualCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2591,7 +2635,7 @@ StringEqualCmd(
*/
const char *string2;
- int length2, i, match, nocase = 0, reqlength = -1;
+ int length, i, match, nocase = 0, reqlength = -1;
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2601,11 +2645,11 @@ StringEqualCmd(
}
for (i = 1; i < objc-2; i++) {
- string2 = TclGetStringFromObj(objv[i], &length2);
- if ((length2 > 1) && !strncmp(string2, "-nocase", length2)) {
+ string2 = TclGetStringFromObj(objv[i], &length);
+ if ((length > 1) && !strncmp(string2, "-nocase", length)) {
nocase = 1;
- } else if ((length2 > 1)
- && !strncmp(string2, "-length", length2)) {
+ } else if ((length > 1)
+ && !strncmp(string2, "-length", length)) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
@@ -2654,7 +2698,7 @@ StringEqualCmd(
static int
StringCmpCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2674,201 +2718,12 @@ StringCmpCmd(
objv += objc-2;
match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match));
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * TclStringCmp --
- *
- * This is the core of Tcl's string comparison. It only handles byte
- * arrays, UNICODE strings and UTF-8 strings correctly.
- *
- * Results:
- * -1 if value1Ptr is less than value2Ptr, 0 if they are equal, or 1 if
- * value1Ptr is greater.
- *
- * Side effects:
- * May cause string representations of objects to be allocated.
- *
- *----------------------------------------------------------------------
- */
-
int
-TclStringCmp(
- Tcl_Obj *value1Ptr,
- Tcl_Obj *value2Ptr,
- int checkEq, /* comparison is only for equality */
- int nocase, /* comparison is not case sensitive */
- int reqlength) /* requested length in characters; -1 to
- * compare whole strings */
-{
- const char *s1, *s2;
- int empty, length, match, s1len, s2len;
- memCmpFn_t memCmpFn;
-
- if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
- /*
- * Always match at 0 chars or if it is the same obj.
- */
- return 0;
- }
-
- if (!nocase && TclIsPureByteArray(value1Ptr)
- && TclIsPureByteArray(value2Ptr)) {
- /*
- * Use binary versions of comparisons since that won't cause undue
- * type conversions and it is much faster. Only do this if we're
- * case-sensitive (which is all that really makes sense with byte
- * arrays anyway, and we have no memcasecmp() for some reason... :^)
- */
-
- s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
- s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
- memCmpFn = memcmp;
- } else if ((value1Ptr->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.
- */
-
- if (nocase) {
- s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len);
- s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
- memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp;
- } else {
- s1len = Tcl_GetCharLength(value1Ptr);
- s2len = Tcl_GetCharLength(value2Ptr);
- if ((s1len == value1Ptr->length)
- && (value1Ptr->bytes != NULL)
- && (s2len == value2Ptr->length)
- && (value2Ptr->bytes != NULL)) {
- /* each byte represents one character so s1l3n, s2l3n, and
- * reqlength are in both bytes and characters
- */
- s1 = value1Ptr->bytes;
- s2 = value2Ptr->bytes;
- memCmpFn = memcmp;
- } else {
- s1 = (char *) Tcl_GetUnicode(value1Ptr);
- s2 = (char *) Tcl_GetUnicode(value2Ptr);
- if (
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
- 1
-#else
- checkEq
-#endif /* WORDS_BIGENDIAN */
- ) {
- memCmpFn = memcmp;
- s1len *= sizeof(Tcl_UniChar);
- s2len *= sizeof(Tcl_UniChar);
- if (reqlength > 0) {
- reqlength *= sizeof(Tcl_UniChar);
- }
- } else {
- memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
- }
- }
- }
- } else {
- /*
- * Get the string representations, being careful in case we have
- * special empty string objects about.
- */
-
- empty = TclCheckEmptyString(value1Ptr);
- if (empty > 0) {
- switch (TclCheckEmptyString(value2Ptr)) {
- case -1:
- s1 = "";
- s1len = 0;
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- break;
- case 0:
- return -1;
- default: /* avoid warn: `s2` may be used uninitialized */
- return 0;
- }
- } else if (TclCheckEmptyString(value2Ptr) > 0) {
- switch (empty) {
- case -1:
- s2 = "";
- s2len = 0;
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- break;
- case 0:
- return 1;
- default: /* avoid warn: `s1` may be used uninitialized */
- return 0;
- }
- } else {
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- }
-
- if (!nocase && checkEq && reqlength < 0) {
- /*
- * When we have equal-length we can check only for (in)equality.
- * We can use memcmp() in all (n)eq cases because we don't need to
- * worry about lexical LE/BE variance.
- */
- memCmpFn = memcmp;
- } else {
- /*
- * As a catch-all we will work with UTF-8. We cannot use memcmp()
- * as that is unsafe with any string containing NUL (\xC0\x80 in
- * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if
- * we are case-sensitive and no specific length was requested.
- */
-
- if ((reqlength < 0) && !nocase) {
- memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
- } else {
- s1len = Tcl_NumUtfChars(s1, s1len);
- s2len = Tcl_NumUtfChars(s2, s2len);
- memCmpFn = (memCmpFn_t)
- (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
- }
- }
- }
-
- /* At this point s1len, s2len, and reqlength should by now have been
- * adjusted so that they are all in the units expected by the selected
- * comparison function.
- */
-
- length = (s1len < s2len) ? s1len : s2len;
- if (reqlength > 0 && reqlength < length) {
- length = reqlength;
- } else if (reqlength < 0) {
- /*
- * The requested length is negative, so ignore it by setting it to
- * length + 1 to correct the match var.
- */
- reqlength = length + 1;
- }
-
- if (checkEq && reqlength < 0 && (s1len != s2len)) {
- match = 1; /* This will be reversed below. */
- } else {
- /*
- * The comparison function should compare up to the minimum byte
- * length only.
- */
- match = memCmpFn(s1, s2, length);
- }
- if ((match == 0) && (reqlength > length)) {
- match = s1len - s2len;
- }
- return (match > 0) ? 1 : (match < 0) ? -1 : 0;
-}
-
-int TclStringCmpOpts(
+TclStringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
@@ -2931,12 +2786,11 @@ int TclStringCmpOpts(
static int
StringCatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i;
Tcl_Obj *objResultPtr;
if (objc < 2) {
@@ -2946,23 +2800,15 @@ StringCatCmd(
*/
return TCL_OK;
}
- if (objc == 2) {
- /*
- * Other trivial case, single arg, just return it.
- */
- Tcl_SetObjResult(interp, objv[1]);
+
+ objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE);
+
+ if (objResultPtr) {
+ Tcl_SetObjResult(interp, objResultPtr);
return TCL_OK;
}
- objResultPtr = objv[1];
- if (Tcl_IsShared(objResultPtr)) {
- objResultPtr = Tcl_DuplicateObj(objResultPtr);
- }
- for(i = 2;i < objc;i++) {
- Tcl_AppendObjToObj(objResultPtr, objv[i]);
- }
- Tcl_SetObjResult(interp, objResultPtr);
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -2983,10 +2829,10 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
-
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
static int
StringBytesCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2999,9 +2845,10 @@ StringBytesCmd(
}
(void) TclGetStringFromObj(objv[1], &length);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
return TCL_OK;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -3023,7 +2870,7 @@ StringBytesCmd(
static int
StringLenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3033,7 +2880,7 @@ StringLenCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1])));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[1])));
return TCL_OK;
}
@@ -3057,7 +2904,7 @@ StringLenCmd(
static int
StringLowerCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3107,8 +2954,8 @@ StringLowerCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3142,7 +2989,7 @@ StringLowerCmd(
static int
StringUpperCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3192,8 +3039,8 @@ StringUpperCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3227,7 +3074,7 @@ StringUpperCmd(
static int
StringTitleCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3277,8 +3124,8 @@ StringTitleCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3312,7 +3159,7 @@ StringTitleCmd(
static int
StringTrimCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3359,7 +3206,7 @@ StringTrimCmd(
static int
StringTrimLCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3405,7 +3252,7 @@ StringTrimLCmd(
static int
StringTrimRCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3458,12 +3305,15 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+#endif
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
+ {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0},
{"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
@@ -3547,17 +3397,17 @@ TclSubstOptions(
int
Tcl_SubstObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3595,16 +3445,16 @@ TclNRSubstObjCmd(
int
Tcl_SwitchObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3631,12 +3481,12 @@ TclNRSwitchObjCmd(
"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
"--", NULL
};
- enum options {
+ enum switchOptionsEnum {
OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP,
OPT_LAST
};
typedef int (*strCmpFn_t)(const char *, const char *);
- strCmpFn_t strCmpFn = strcmp;
+ strCmpFn_t strCmpFn = TclUtfCmp;
mode = OPT_EXACT;
foundmode = 0;
@@ -3652,7 +3502,7 @@ TclNRSwitchObjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum switchOptionsEnum) index) {
/*
* General options.
*/
@@ -3760,7 +3610,7 @@ TclNRSwitchObjCmd(
Tcl_Obj **listv;
blist = objv[0];
- if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
+ if (TclListObjLengthM(interp, objv[0], &objc) != TCL_OK) {
return TCL_ERROR;
}
@@ -3773,6 +3623,9 @@ TclNRSwitchObjCmd(
"?-option ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
objv = listv;
splitObjs = 1;
}
@@ -3922,8 +3775,8 @@ TclNRSwitchObjCmd(
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end > 0) {
- rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
- rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1);
+ TclNewIndexObj(rangeObjAry[0], info.matches[j].start);
+ TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1);
} else {
TclNewIntObj(rangeObjAry[1], -1);
rangeObjAry[0] = rangeObjAry[1];
@@ -3941,7 +3794,7 @@ TclNRSwitchObjCmd(
Tcl_Obj *substringObj;
if (info.matches[j].end > 0) {
- substringObj = Tcl_GetRange(stringObj,
+ substringObj = TclGetRange(stringObj,
info.matches[j].start, info.matches[j].end-1);
} else {
TclNewObj(substringObj);
@@ -3992,7 +3845,7 @@ TclNRSwitchObjCmd(
*/
matchFound:
- ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
@@ -4022,7 +3875,7 @@ TclNRSwitchObjCmd(
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
- ctxPtr->line = ckalloc(objc * sizeof(int));
+ ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
@@ -4036,7 +3889,7 @@ TclNRSwitchObjCmd(
int k;
- ctxPtr->line = ckalloc(objc * sizeof(int));
+ ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
@@ -4076,9 +3929,9 @@ SwitchPostProc(
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
- CmdFrame *ctxPtr = data[1];
+ CmdFrame *ctxPtr = (CmdFrame *)data[1];
int pc = PTR2INT(data[2]);
- const char *pattern = data[3];
+ const char *pattern = (const char *)data[3];
int patternLength = strlen(pattern);
/*
@@ -4130,10 +3983,9 @@ SwitchPostProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ThrowObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4150,7 +4002,7 @@ Tcl_ThrowObjCmd(
* The type must be a list of at least length 1.
*/
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -4195,7 +4047,7 @@ Tcl_ThrowObjCmd(
int
Tcl_TimeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4250,9 +4102,9 @@ Tcl_TimeObjCmd(
* Use int obj since we know time is not fractional. [Bug 1202178]
*/
- objs[0] = Tcl_NewWideIntObj((count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec);
+ TclNewIntObj(objs[0], (count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec);
} else {
- objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
+ TclNewDoubleObj(objs[0], totalMicroSec/count);
}
/*
@@ -4293,7 +4145,7 @@ Tcl_TimeObjCmd(
int
Tcl_TimeRateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4304,14 +4156,14 @@ Tcl_TimeRateObjCmd(
Tcl_Obj *objPtr;
int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
- TclWideMUInt count = 0; /* Holds repetition count */
+ Tcl_WideUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
- TclWideMUInt maxcnt = WIDE_MAX;
+ Tcl_WideUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
- TclWideMUInt threshold = 1; /* Current threshold for check time (faster
+ Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
- TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max
+ Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max
* threshold, additionally avoiding divide to
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
@@ -4323,7 +4175,7 @@ Tcl_TimeRateObjCmd(
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
- enum options {
+ enum timeRateOptionsEnum {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
@@ -4340,7 +4192,7 @@ Tcl_TimeRateObjCmd(
i++;
break;
}
- switch (index) {
+ switch ((enum timeRateOptionsEnum)index) {
case TMRT_EV_DIRECT:
direct = objv[i];
break;
@@ -4355,6 +4207,8 @@ Tcl_TimeRateObjCmd(
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
+ case TMRT_LAST:
+ break;
}
}
@@ -4414,7 +4268,7 @@ Tcl_TimeRateObjCmd(
* calibration cycle.
*/
- TclNewLongObj(clobjv[i], 100);
+ TclNewIntObj(clobjv[i], 100);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
@@ -4439,7 +4293,7 @@ Tcl_TimeRateObjCmd(
maxms = -1000;
do {
lastMeasureOverhead = measureOverhead;
- TclNewLongObj(clobjv[i], (int) maxms);
+ TclNewIntObj(clobjv[i], (int) maxms);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
@@ -4469,7 +4323,7 @@ Tcl_TimeRateObjCmd(
*/
measureOverhead = 0;
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
@@ -4683,13 +4537,13 @@ Tcl_TimeRateObjCmd(
{
Tcl_Obj *objarr[8], **objs = objarr;
- TclWideMUInt usec, val;
+ Tcl_WideUInt usec, val;
int digits;
/*
* Absolute execution time in microseconds or in wide clicks.
*/
- usec = (TclWideMUInt)(middle - start);
+ usec = (Tcl_WideUInt)(middle - start);
#ifdef TCL_WIDE_CLICKS
/*
@@ -4700,7 +4554,8 @@ Tcl_TimeRateObjCmd(
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
- objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
+ TclNewIntObj(objs[4], 0);
+ objs[0] = objs[2] = objs[4];
goto retRes;
}
@@ -4718,7 +4573,7 @@ Tcl_TimeRateObjCmd(
* Estimate the time of overhead (microsecs).
*/
- TclWideMUInt curOverhead = overhead * count;
+ Tcl_WideUInt curOverhead = overhead * count;
if (usec > curOverhead) {
usec -= curOverhead;
@@ -4734,14 +4589,14 @@ Tcl_TimeRateObjCmd(
if (measureOverhead > ((double) usec) / count) {
measureOverhead = ((double) usec) / count;
}
- objs[0] = Tcl_NewDoubleObj(measureOverhead);
+ TclNewDoubleObj(objs[0], measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = usec / count; /* microsecs per iteration */
if (val >= 1000000) {
- objs[0] = Tcl_NewWideIntObj(val);
+ TclNewIntObj(objs[0], val);
} else {
if (val < 10) {
digits = 6;
@@ -4757,7 +4612,7 @@ Tcl_TimeRateObjCmd(
objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
}
- objs[2] = Tcl_NewWideIntObj(count); /* iterations */
+ TclNewIntObj(objs[2], count); /* iterations */
/*
* Calculate speed as rate (count) per sec
@@ -4779,7 +4634,7 @@ Tcl_TimeRateObjCmd(
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / usec);
} else {
- objs[4] = Tcl_NewWideIntObj(val);
+ TclNewIntObj(objs[4], val);
}
} else {
objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
@@ -4794,7 +4649,7 @@ Tcl_TimeRateObjCmd(
if (usec >= 1) {
objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
} else {
- objs[6] = Tcl_NewWideIntObj(0);
+ TclNewIntObj(objs[6], 0);
}
TclNewLiteralStringObj(objs[7], "net-ms");
}
@@ -4836,17 +4691,17 @@ Tcl_TimeRateObjCmd(
int
Tcl_TryObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4935,7 +4790,7 @@ TclNRTryObjCmd(
return TCL_ERROR;
}
code = 1;
- if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+ if (TclListObjLengthM(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
Tcl_GetString(objv[i+1])));
@@ -4947,7 +4802,7 @@ TclNRTryObjCmd(
info[2] = objv[i+1];
commonHandler:
- if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[i+2], &dummy) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
@@ -5049,12 +4904,12 @@ TryPostBody(
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
- int i, dummy, code, objc;
+ int i, code, objc;
int numHandlers = 0;
- handlersObj = data[0];
- finallyObj = data[1];
- objv = data[2];
+ handlersObj = (Tcl_Obj *)data[0];
+ finallyObj = (Tcl_Obj *)data[1];
+ objv = (Tcl_Obj **)data[2];
objc = PTR2INT(data[3]);
cmdObj = objv[0];
@@ -5097,11 +4952,12 @@ TryPostBody(
int found = 0;
Tcl_Obj **handlers, **info;
- TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+ TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
+ int numElems = 0;
- TclListObjGetElements(NULL, handlers[i], &dummy, &info);
+ TclListObjGetElementsM(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
@@ -5122,8 +4978,8 @@ TryPostBody(
TclNewLiteralStringObj(errorCodeName, "-errorcode");
Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
Tcl_DecrRefCount(errorCodeName);
- TclListObjGetElements(NULL, info[2], &len1, &bits1);
- if (TclListObjGetElements(NULL, errcode, &len2,
+ TclListObjGetElementsM(NULL, info[2], &len1, &bits1);
+ if (TclListObjGetElementsM(NULL, errcode, &len2,
&bits2) != TCL_OK) {
continue;
}
@@ -5163,8 +5019,8 @@ TryPostBody(
Tcl_ResetResult(interp);
result = TCL_ERROR;
- TclListObjLength(NULL, info[3], &dummy);
- if (dummy > 0) {
+ TclListObjLengthM(NULL, info[3], &numElems);
+ if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
@@ -5174,7 +5030,7 @@ TryPostBody(
goto handlerFailed;
}
Tcl_DecrRefCount(resultObj);
- if (dummy > 1) {
+ if (numElems> 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
@@ -5267,9 +5123,9 @@ TryPostHandler(
Tcl_Obj *finallyObj;
int finallyIndex;
- objv = data[0];
- options = data[1];
- handlerKindObj = data[2];
+ objv = (Tcl_Obj **)data[0];
+ options = (Tcl_Obj *)data[1];
+ handlerKindObj = (Tcl_Obj *)data[2];
finallyIndex = PTR2INT(data[3]);
cmdObj = objv[0];
@@ -5351,9 +5207,9 @@ TryPostFinal(
{
Tcl_Obj *resultObj, *options, *cmdObj;
- resultObj = data[0];
- options = data[1];
- cmdObj = data[2];
+ resultObj = (Tcl_Obj *)data[0];
+ options = (Tcl_Obj *)data[1];
+ cmdObj = (Tcl_Obj *)data[2];
/*
* If the result wasn't OK, we need to adjust the result options.
@@ -5412,17 +5268,17 @@ TryPostFinal(
int
Tcl_WhileObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 306334b..340efc9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4,10 +4,10 @@
* This file contains compilation procedures that compile various Tcl
* commands into a sequence of instructions ("bytecodes").
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 by Donal K. Fellows.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,28 +21,16 @@
* 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 void DisassembleDictUpdateInfo(ClientData clientData,
- Tcl_Obj *dictObj, 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 DisassembleForeachInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void PrintNewForeachInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void DisassembleNewForeachInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
+static AuxDataDupProc DupDictUpdateInfo;
+static AuxDataFreeProc FreeDictUpdateInfo;
+static AuxDataPrintProc PrintDictUpdateInfo;
+static AuxDataPrintProc DisassembleDictUpdateInfo;
+static AuxDataDupProc DupForeachInfo;
+static AuxDataFreeProc FreeForeachInfo;
+static AuxDataPrintProc PrintForeachInfo;
+static AuxDataPrintProc DisassembleForeachInfo;
+static AuxDataPrintProc PrintNewForeachInfo;
+static AuxDataPrintProc DisassembleNewForeachInfo;
static int CompileEachloopCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr, int collect);
@@ -260,8 +248,7 @@ TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -314,7 +301,7 @@ TclCompileArraySetCmd(
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
- && TclListObjLength(NULL, literalObj, &len) == TCL_OK);
+ && TclListObjLengthM(NULL, literalObj, &len) == TCL_OK);
isDataEven = (isDataValid && (len & 1) == 0);
/*
@@ -403,9 +390,9 @@ TclCompileArraySetCmd(
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
- infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *));
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
- infoPtr->varLists[0] = ckalloc(TclOffset(ForeachVarList, varIndexes) + 2 * sizeof(int));
+ infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
@@ -522,11 +509,10 @@ TclCompileArrayUnsetCmd(
int
TclCompileBreakCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
@@ -583,8 +569,7 @@ TclCompileCatchCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -620,11 +605,13 @@ TclCompileCatchCmd(
cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
+ /* DGP */
resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
+ /* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
@@ -763,11 +750,10 @@ TclCompileCatchCmd(
int
TclCompileClockClicksCmd(
- Tcl_Interp* interp, /* Tcl interpreter */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token* tokenPtr;
@@ -827,7 +813,7 @@ TclCompileClockClicksCmd(
int
TclCompileClockReadingCmd(
- Tcl_Interp* interp, /* Tcl interpreter */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to definition of command being
@@ -866,8 +852,7 @@ TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -907,10 +892,10 @@ TclCompileConcatCmd(
const char *bytes;
int len;
- TclListObjGetElements(NULL, listObj, &len, &objs);
+ TclListObjGetElementsM(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
- bytes = Tcl_GetStringFromObj(objPtr, &len);
+ bytes = TclGetStringFromObj(objPtr, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
@@ -950,11 +935,10 @@ TclCompileConcatCmd(
int
TclCompileContinueCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
@@ -1016,13 +1000,13 @@ TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *varTokenPtr;
+ Tcl_Token *tokenPtr;
int i, dictVarIndex;
+ Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
@@ -1141,8 +1125,7 @@ TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1174,12 +1157,42 @@ TclCompileDictGetCmd(
}
int
+TclCompileDictGetWithDefaultCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int i;
+
+ /*
+ * There must be at least three arguments after the command.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 4) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ for (i=1 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr);
+ TclAdjustStackDepth(-2, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1317,7 +1330,7 @@ TclCompileDictCreateCmd(
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
- bytes = Tcl_GetStringFromObj(dictObj, &len);
+ bytes = TclGetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
@@ -1776,9 +1789,9 @@ TclCompileDictUpdateCmd(
* that are to be used.
*/
- duiPtr = ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
+ duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
duiPtr->length = numVars;
- keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
+ keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
@@ -2250,35 +2263,35 @@ TclCompileDictWithCmd(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupDictUpdateInfo(
- ClientData clientData)
+ void *clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
- unsigned len;
+ size_t len;
- dui1Ptr = clientData;
- len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
- dui2Ptr = ckalloc(len);
+ dui1Ptr = (DictUpdateInfo *)clientData;
+ len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
+ dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
- ClientData clientData)
+ void *clientData)
{
ckfree(clientData);
}
static void
PrintDictUpdateInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- DictUpdateInfo *duiPtr = clientData;
+ DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
for (i=0 ; i<duiPtr->length ; i++) {
@@ -2291,19 +2304,19 @@ PrintDictUpdateInfo(
static void
DisassembleDictUpdateInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- DictUpdateInfo *duiPtr = clientData;
+ DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
Tcl_Obj *variables;
TclNewObj(variables);
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
- Tcl_NewIntObj(duiPtr->varIndices[i]));
+ Tcl_NewWideIntObj(duiPtr->varIndices[i]));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
variables);
@@ -2332,8 +2345,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2406,8 +2418,7 @@ TclCompileExprCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
@@ -2451,8 +2462,7 @@ TclCompileForCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2631,8 +2641,8 @@ TclCompileLmapCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ Command *cmdPtr, /* Points to the definition of the command
+ * being compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
@@ -2662,8 +2672,7 @@ CompileEachloopCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
@@ -2694,7 +2703,7 @@ CompileEachloopCmd(
}
/*
- * Bail out if the body requires substitutions in order to insure correct
+ * Bail out if the body requires substitutions in order to ensure correct
* behaviour. [Bug 219166]
*/
@@ -2713,7 +2722,7 @@ CompileEachloopCmd(
*/
numLists = (numWords - 2)/2;
- infoPtr = ckalloc(TclOffset(ForeachInfo, varLists)
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
@@ -2741,13 +2750,13 @@ CompileEachloopCmd(
*/
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
- TCL_OK != TclListObjLength(NULL, varListObj, &numVars) ||
+ TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
- varListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes)
+ varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
@@ -2759,7 +2768,7 @@ CompileEachloopCmd(
int numBytes, varIndex;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
- bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
+ bytes = TclGetStringFromObj(varNameObj, &numBytes);
varIndex = LocalScalar(bytes, numBytes, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
@@ -2873,17 +2882,17 @@ CompileEachloopCmd(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupForeachInfo(
- ClientData clientData) /* The foreach command's compilation auxiliary
+ void *clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
- ForeachInfo *srcPtr = clientData;
+ ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
- dupPtr = ckalloc(TclOffset(ForeachInfo, varLists)
+ dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
@@ -2892,7 +2901,7 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes)
+ dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
@@ -2924,10 +2933,10 @@ DupForeachInfo(
static void
FreeForeachInfo(
- ClientData clientData) /* The foreach command's compilation auxiliary
+ void *clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
- ForeachInfo *infoPtr = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
int i;
@@ -2958,12 +2967,12 @@ FreeForeachInfo(
static void
PrintForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- ForeachInfo *infoPtr = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
@@ -2998,12 +3007,12 @@ PrintForeachInfo(
static void
PrintNewForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- ForeachInfo *infoPtr = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
@@ -3028,12 +3037,12 @@ PrintNewForeachInfo(
static void
DisassembleForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- ForeachInfo *infoPtr = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
@@ -3045,7 +3054,7 @@ DisassembleForeachInfo(
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(infoPtr->firstValueTemp + i));
+ Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
@@ -3054,7 +3063,7 @@ DisassembleForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3066,7 +3075,7 @@ DisassembleForeachInfo(
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
- Tcl_NewIntObj(varsPtr->varIndexes[j]));
+ Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
@@ -3075,12 +3084,12 @@ DisassembleForeachInfo(
static void
DisassembleNewForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- ForeachInfo *infoPtr = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
@@ -3090,7 +3099,7 @@ DisassembleNewForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3102,7 +3111,7 @@ DisassembleNewForeachInfo(
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
- Tcl_NewIntObj(varsPtr->varIndexes[j]));
+ Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
@@ -3133,14 +3142,13 @@ TclCompileFormatCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
- char *bytes, *start;
+ const char *bytes, *start;
int i, j, len;
/*
@@ -3164,7 +3172,7 @@ TclCompileFormatCmd(
return TCL_ERROR;
}
- objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objv[i]);
@@ -3196,7 +3204,7 @@ TclCompileFormatCmd(
* literal. Job done.
*/
- bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ bytes = TclGetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
@@ -3267,7 +3275,7 @@ TclCompileFormatCmd(
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
- char *b = Tcl_GetStringFromObj(tmpObj, &len);
+ const char *b = TclGetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
@@ -3301,7 +3309,7 @@ TclCompileFormatCmd(
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
- bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ bytes = TclGetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
@@ -3458,7 +3466,7 @@ TclPushVarName(
* assemble the corresponding token.
*/
- elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -3512,7 +3520,7 @@ TclPushVarName(
* token.
*/
- elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 4328ace..7bb06ab 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -5,10 +5,10 @@
* commands (beginning with the letters 'g' through 'r') into a sequence
* of instructions ("bytecodes").
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 by Donal K. Fellows.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -27,7 +27,6 @@ static void CompileReturnInternal(CompileEnv *envPtr,
Tcl_Obj *returnOpts);
static int IndexTailVarIfKnown(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-
/*
*----------------------------------------------------------------------
@@ -88,8 +87,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -128,9 +126,12 @@ TclCompileGlobalCmd(
return TCL_ERROR;
}
- /* TODO: Consider what value can pass through the
- * IndexTailVarIfKnown() screen. Full CompileWord()
- * likely does not apply here. Push known value instead. */
+ /*
+ * TODO: Consider what value can pass through the
+ * IndexTailVarIfKnown() screen. Full CompileWord() likely does not
+ * apply here. Push known value instead.
+ */
+
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
@@ -167,8 +168,7 @@ TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -181,7 +181,8 @@ TclCompileIfCmd(
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
- int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
+ int numBytes, j;
+ int jumpFalseDist, numWords, wordIdx, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
@@ -271,7 +272,7 @@ TclCompileIfCmd(
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
+ jumpFalseFixupArray.fixup + jumpIndex);
}
code = TCL_OK;
}
@@ -318,7 +319,7 @@ TclCompileIfCmd(
}
jumpEndFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- jumpEndFixupArray.fixup+jumpIndex);
+ jumpEndFixupArray.fixup + jumpIndex);
/*
* Fix the target of the jumpFalse after the test. Generate a 4
@@ -330,7 +331,7 @@ TclCompileIfCmd(
TclAdjustStackDepth(-1, envPtr);
if (TclFixupForwardJumpToHere(envPtr,
- jumpFalseFixupArray.fixup+jumpIndex, 120)) {
+ jumpFalseFixupArray.fixup + jumpIndex, 120)) {
/*
* Adjust the code offset for the proceeding jump to the end
* of the "if" command.
@@ -413,7 +414,7 @@ TclCompileIfCmd(
for (j = jumpEndFixupArray.next; j > 0; j--) {
jumpIndex = (j - 1); /* i.e. process the closest jump first. */
if (TclFixupForwardJumpToHere(envPtr,
- jumpEndFixupArray.fixup+jumpIndex, 127)) {
+ jumpEndFixupArray.fixup + jumpIndex, 127)) {
/*
* Adjust the immediately preceeding "ifFalse" jump. We moved it's
* target (just after this jump) down three bytes.
@@ -432,7 +433,7 @@ TclCompileIfCmd(
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
}
}
}
@@ -470,8 +471,7 @@ TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -588,7 +588,7 @@ TclCompileInfoCommandsCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
- char *bytes;
+ const char *bytes;
/*
* We require one compile-time known argument for the case we can compile.
@@ -605,7 +605,7 @@ TclCompileInfoCommandsCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
- bytes = Tcl_GetString(objPtr);
+ bytes = TclGetString(objPtr);
/*
* We require that the argument start with "::" and not have any of "*\[?"
@@ -639,11 +639,10 @@ TclCompileInfoCommandsCmd(
int
TclCompileInfoCoroutineCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -667,8 +666,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -716,8 +714,7 @@ TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -751,8 +748,7 @@ TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -771,8 +767,7 @@ TclCompileInfoObjectIsACmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -807,8 +802,7 @@ TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -845,8 +839,7 @@ TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -921,7 +914,7 @@ TclCompileLappendCmd(
CompileWord(envPtr, valueTokenPtr, interp, i);
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ TclEmitInstInt4( INST_LIST, numWords - 2, envPtr);
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr);
@@ -961,8 +954,7 @@ TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -998,7 +990,7 @@ TclCompileLassignCmd(
*/
PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &isScalar, idx+2);
+ &isScalar, idx + 2);
/*
* Emit instructions to get the idx'th item out of the list value on
@@ -1037,7 +1029,7 @@ TclCompileLassignCmd(
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1065,8 +1057,7 @@ TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1088,8 +1079,8 @@ TclCompileLindexCmd(
}
idxTokenPtr = TokenAfter(valTokenPtr);
- if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE,
- &idx) == TCL_OK) {
+ if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &idx) == TCL_OK) {
/*
* The idxTokenPtr parsed as a valid index value and was
* encoded as expected by INST_LIST_INDEX_IMM.
@@ -1156,8 +1147,7 @@ TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1242,7 +1232,7 @@ TclCompileListCmd(
if (concat && numWords == 2) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
}
return TCL_OK;
}
@@ -1270,8 +1260,7 @@ TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1303,8 +1292,7 @@ TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1317,8 +1305,8 @@ TclCompileLrangeCmd(
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(listTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
- &idx1) != TCL_OK) {
+ if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
+ &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) {
return TCL_ERROR;
}
/*
@@ -1327,7 +1315,7 @@ TclCompileLrangeCmd(
*/
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&idx2) != TCL_OK) {
return TCL_ERROR;
}
@@ -1364,89 +1352,38 @@ TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *listTokenPtr;
- int idx, i;
+ Tcl_Token *tokenPtr;
+ int i;
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Parse the index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing) or an end-based index greater than 'end' itself.
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
-
- /*
- * NOTE: This command treats all inserts at indices before the list
- * the same as inserts at the start of the list, and all inserts
- * after the list the same as inserts at the end of the list. We
- * make that transformation here so we can use the optimized bytecode
- * as much as possible.
- */
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
- /*
- * There are four main cases. If there are no values to insert, this is
- * just a confirm-listiness check. If the index is '0', this is a prepend.
- * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
- * this is a splice (== split, insert values as list, concat-3).
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- if (parsePtr->numWords == 3) {
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- return TCL_OK;
- }
+ /* Push list, insertion index onto the stack */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ /* Push new elements to be inserted */
for (i=3 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt4( INST_LIST, i-3, envPtr);
-
- if (idx == TCL_INDEX_START) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else if (idx == TCL_INDEX_END) {
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else {
- /*
- * Here we handle two ranges for idx. First when idx > 0, we
- * want the first half of the split to end at index idx-1 and
- * the second half to start at index idx.
- * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
- * we want the first half of the split to end at index end-N and
- * the second half to start at index end-N+1. We accomplish this
- * with a pre-adjustment of the end-N value.
- * The root of this is that the commands [lrange] and [linsert]
- * differ in their interpretation of the "end" index.
- */
- if (idx < TCL_INDEX_END) {
- idx++;
- }
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx-1, envPtr);
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
+ /* First operand is count of arguments */
+ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr);
+ /*
+ * Second operand is bitmask
+ * TCL_LREPLACE4_END_IS_LAST - end refers to last element
+ * TCL_LREPLACE4_SINGLE_INDEX - second index is not present
+ * indicating this is a pure insert
+ */
+ TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr);
return TCL_OK;
}
@@ -1467,121 +1404,38 @@ TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *listTokenPtr;
- int idx1, idx2, i;
- int emptyPrefix=1, suffixStart = 0;
+ Tcl_Token *tokenPtr;
+ int i;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
- &idx1) != TCL_OK) {
- return TCL_ERROR;
- }
+ /* Push list, first, last onto the stack */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
- &idx2) != TCL_OK) {
- return TCL_ERROR;
- }
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
- /*
- * General structure of the [lreplace] result is
- * prefix replacement suffix
- * In a few cases we can predict various parts will be empty and
- * take advantage.
- *
- * The proper suffix begins with the greater of indices idx1 or
- * idx2 + 1. If we cannot tell at compile time which is greater,
- * we must defer to direct evaluation.
- */
-
- if (idx1 == TCL_INDEX_AFTER) {
- suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_BEFORE) {
- suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_END) {
- suffixStart = TCL_INDEX_AFTER;
- } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
- || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
- suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
- } else {
- return TCL_ERROR;
+ /* Push new elements to be inserted */
+ for (i=4 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
}
- /* All paths start with computing/pushing the original value. */
- CompileWord(envPtr, listTokenPtr, interp, 1);
-
+ /* First operand is count of arguments */
+ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr);
/*
- * Push all the replacement values next so any errors raised in
- * creating them get raised first.
+ * Second operand is bitmask
+ * TCL_LREPLACE4_END_IS_LAST - end refers to last element
*/
- if (parsePtr->numWords > 4) {
- /* Push the replacement arguments */
- tokenPtr = TokenAfter(tokenPtr);
- for (i=4 ; i<parsePtr->numWords ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i);
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- /* Make a list of them... */
- TclEmitInstInt4( INST_LIST, i - 4, envPtr);
-
- emptyPrefix = 0;
- }
-
- if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
- /*
- * This is a "no-op". Example: [lreplace {a b c} 2 0]
- * We still do a list operation to get list-verification
- * and canonicalization side effects.
- */
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- return TCL_OK;
- }
-
- if (idx1 != TCL_INDEX_START) {
- /* Prefix may not be empty; generate bytecode to push it */
- if (emptyPrefix) {
- TclEmitOpcode( INST_DUP, envPtr);
- } else {
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- }
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx1 - 1, envPtr);
- if (!emptyPrefix) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
- emptyPrefix = 0;
- }
-
- if (!emptyPrefix) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- }
-
- if (suffixStart == TCL_INDEX_AFTER) {
- TclEmitOpcode( INST_POP, envPtr);
- if (emptyPrefix) {
- PushStringLiteral(envPtr, "");
- }
- } else {
- /* Suffix may not be empty; generate bytecode to push it */
- TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- if (!emptyPrefix) {
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
- }
+ TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr);
return TCL_OK;
}
@@ -1631,8 +1485,7 @@ TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1775,11 +1628,10 @@ TclCompileLsetCmd(
int
TclCompileNamespaceCurrentCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -1803,8 +1655,7 @@ TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1853,8 +1704,7 @@ TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1875,8 +1725,7 @@ TclCompileNamespaceQualifiersCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1911,8 +1760,7 @@ TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1948,8 +1796,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2009,8 +1856,7 @@ TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2073,14 +1919,14 @@ TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
- int i, len, nocase, exact, sawLast, simple;
+ int len;
+ int i, nocase, exact, sawLast, simple;
const char *str;
/*
@@ -2184,7 +2030,7 @@ TclCompileRegexpCmd(
}
if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2);
}
/*
@@ -2192,7 +2038,7 @@ TclCompileRegexpCmd(
*/
varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1);
if (simple) {
if (exact && !nocase) {
@@ -2238,8 +2084,7 @@ TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
@@ -2267,7 +2112,8 @@ TclCompileRegsubCmd(
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
- int len, exact, quantified, result = TCL_ERROR;
+ int exact, quantified, result = TCL_ERROR;
+ int len;
if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
return TCL_ERROR;
@@ -2294,8 +2140,8 @@ TclCompileRegsubCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
- if (Tcl_GetString(patternObj)[0] == '-') {
- if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ if (TclGetString(patternObj)[0] == '-') {
+ if (strcmp(TclGetString(patternObj), "--") != 0
|| parsePtr->numWords == 5) {
goto done;
}
@@ -2326,7 +2172,7 @@ TclCompileRegsubCmd(
* replacement "simple"?
*/
- bytes = Tcl_GetStringFromObj(patternObj, &len);
+ bytes = TclGetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
@@ -2360,7 +2206,7 @@ TclCompileRegsubCmd(
bytes++;
}
isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
case '\\': case '&':
goto done;
@@ -2374,9 +2220,9 @@ TclCompileRegsubCmd(
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(replacementObj, &len);
+ bytes = TclGetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
- CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
+ CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
@@ -2413,8 +2259,7 @@ TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2422,7 +2267,8 @@ TclCompileReturnCmd(
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
- int level, code, objc, size, status = TCL_OK;
+ int level, code, objc, status = TCL_OK;
+ int size;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
@@ -2454,7 +2300,7 @@ TclCompileReturnCmd(
* Allocate some working space.
*/
- objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
/*
* Scan through the return options. If any are unknown at compile time,
@@ -2505,7 +2351,7 @@ TclCompileReturnCmd(
*/
if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
/*
* No explict result argument, so default result is empty string.
@@ -2532,7 +2378,7 @@ TclCompileReturnCmd(
ExceptionRange range = envPtr->exceptArrayPtr[index];
if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
+ && (range.catchOffset == TCL_INDEX_NONE)) {
enclosingCatch = 1;
break;
}
@@ -2583,7 +2429,7 @@ TclCompileReturnCmd(
*/
if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
PushStringLiteral(envPtr, "");
}
@@ -2636,7 +2482,7 @@ TclCompileSyntaxError(
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
@@ -2665,8 +2511,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2772,8 +2617,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2814,12 +2658,12 @@ TclCompileVariableCmd(
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
- if (i+1 < numWords) {
+ if (i + 1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
- CompileWord(envPtr, valueTokenPtr, interp, i+1);
+ CompileWord(envPtr, valueTokenPtr, interp, i + 1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -2854,13 +2698,14 @@ TclCompileVariableCmd(
static int
IndexTailVarIfKnown(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_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;
+ int n = varTokenPtr->numComponents;
+ int len;
Tcl_Token *lastTokenPtr;
int full, localIndex;
@@ -2895,7 +2740,7 @@ IndexTailVarIfKnown(
tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
- if (*(tailName+len-1) == ')') {
+ if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
*/
@@ -2909,7 +2754,7 @@ IndexTailVarIfKnown(
*/
for (p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
+ if ((*p == ':') && (*(p - 1) == ':')) {
p++;
break;
}
@@ -2946,8 +2791,7 @@ TclCompileObjectNextCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2971,8 +2815,7 @@ TclCompileObjectNextToCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2993,11 +2836,10 @@ TclCompileObjectNextToCmd(
int
TclCompileObjectSelfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 70d8909..40ad82b 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -6,10 +6,10 @@
* [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.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-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.
@@ -23,14 +23,10 @@
* 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 void DisassembleJumptableInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
+static AuxDataDupProc DupJumptableInfo;
+static AuxDataFreeProc FreeJumptableInfo;
+static AuxDataPrintProc PrintJumptableInfo;
+static AuxDataPrintProc DisassembleJumptableInfo;
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
@@ -45,13 +41,12 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
CompileEnv *envPtr);
static void IssueSwitchChainedTests(Tcl_Interp *interp,
CompileEnv *envPtr, int mode, int noCase,
- int valueIndex, int numWords,
- Tcl_Token **bodyToken, int *bodyLines,
- int **bodyNext);
-static void IssueSwitchJumpTable(Tcl_Interp *interp,
- CompileEnv *envPtr, int valueIndex,
int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyContLines);
+ int *bodyLines, int **bodyNext);
+static void IssueSwitchJumpTable(Tcl_Interp *interp,
+ CompileEnv *envPtr, int numWords,
+ Tcl_Token **bodyToken, int *bodyLines,
+ int **bodyContLines);
static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
@@ -131,8 +126,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -225,8 +219,7 @@ TclCompileStringCatCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -260,7 +253,7 @@ TclCompileStringCatCmd(
Tcl_DecrRefCount(obj);
if (folded) {
int len;
- const char *bytes = Tcl_GetStringFromObj(folded, &len);
+ const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -278,7 +271,7 @@ TclCompileStringCatCmd(
}
if (folded) {
int len;
- const char *bytes = Tcl_GetStringFromObj(folded, &len);
+ const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -297,8 +290,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -329,8 +321,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -361,8 +352,7 @@ TclCompileStringFirstCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -393,8 +383,7 @@ TclCompileStringLastCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -425,8 +414,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -449,6 +437,62 @@ TclCompileStringIndexCmd(
}
int
+TclCompileStringInsertCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int idx;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ /* Compute and push the string in which to insert */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /* See what can be discovered about index at compile time */
+ tokenPtr = TokenAfter(tokenPtr);
+ if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START,
+ TCL_INDEX_END, &idx)) {
+
+ /* Nothing useful knowable - cease compile; let it direct eval */
+ return TCL_ERROR;
+ }
+
+ /* Compute and push the string to be inserted */
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+
+ if (idx == (int)TCL_INDEX_START) {
+ /* Prepend the insertion string */
+ OP4( REVERSE, 2);
+ OP1( STR_CONCAT1, 2);
+ } else if (idx == (int)TCL_INDEX_END) {
+ /* Append the insertion string */
+ OP1( STR_CONCAT1, 2);
+ } else {
+ /* Prefix + insertion + suffix */
+ if (idx < (int)TCL_INDEX_END) {
+ /* See comments in compiler for [linsert]. */
+ idx++;
+ }
+ OP4( OVER, 1);
+ OP44( STR_RANGE_IMM, 0, idx-1);
+ OP4( REVERSE, 3);
+ OP44( STR_RANGE_IMM, idx, TCL_INDEX_END);
+ OP1( STR_CONCAT1, 3);
+ }
+
+ return TCL_OK;
+}
+
+int
TclCompileStringIsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -461,19 +505,19 @@ TclCompileStringIsCmd(
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
- enum isClasses {
+ enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- 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_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, 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_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
@@ -531,7 +575,7 @@ TclCompileStringIsCmd(
CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
- switch ((enum isClasses) t) {
+ switch ((enum isClassesEnum) t) {
case STR_IS_ALNUM:
strClassType = STR_CLASS_ALNUM;
goto compileStrClass;
@@ -565,6 +609,9 @@ TclCompileStringIsCmd(
case STR_IS_UPPER:
strClassType = STR_CLASS_UPPER;
goto compileStrClass;
+ case STR_IS_UNICODE:
+ strClassType = STR_CLASS_UNICODE;
+ goto compileStrClass;
case STR_IS_WORD:
strClassType = STR_CLASS_WORD;
goto compileStrClass;
@@ -692,14 +739,11 @@ TclCompileStringIsCmd(
}
switch (t) {
- case STR_IS_INT:
- PUSH( "1");
- OP( EQ);
- break;
case STR_IS_WIDE:
PUSH( "2");
OP( LE);
break;
+ case STR_IS_INT:
case STR_IS_ENTIER:
PUSH( "3");
OP( LE);
@@ -707,7 +751,19 @@ TclCompileStringIsCmd(
}
FIXJUMP1( end);
return TCL_OK;
-
+ case STR_IS_DICT:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( DICT_VERIFY);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
case STR_IS_LIST:
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
@@ -813,8 +869,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -835,7 +890,7 @@ TclCompileStringLenCmd(
*/
char buf[TCL_INTEGER_SPACE];
- int len = Tcl_GetCharLength(objPtr);
+ int len = TclGetCharLength(objPtr);
len = sprintf(buf, "%d", len);
PushLiteral(envPtr, buf, len);
@@ -860,7 +915,7 @@ TclCompileStringMapCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
- char *bytes;
+ const char *bytes;
int len;
/*
@@ -883,7 +938,7 @@ TclCompileStringMapCmd(
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- } else if (TclListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
+ } else if (TclListObjGetElementsM(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
@@ -897,12 +952,12 @@ TclCompileStringMapCmd(
* correct semantics for mapping.
*/
- bytes = Tcl_GetStringFromObj(objv[0], &len);
+ bytes = TclGetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(objv[1], &len);
+ bytes = TclGetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
@@ -916,8 +971,7 @@ TclCompileStringRangeCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -938,7 +992,7 @@ TclCompileStringRangeCmd(
* Parse the two indices.
*/
- if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&idx1) != TCL_OK) {
goto nonConstantIndices;
}
@@ -947,14 +1001,14 @@ TclCompileStringRangeCmd(
* the string the same as the start of the string.
*/
- if (idx1 == TCL_INDEX_AFTER) {
+ if (idx1 == (int)TCL_INDEX_NONE) {
/* [string range $s end+1 $last] must be empty string */
OP( POP);
PUSH( "");
return TCL_OK;
}
- if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&idx2) != TCL_OK) {
goto nonConstantIndices;
}
@@ -962,7 +1016,7 @@ TclCompileStringRangeCmd(
* Token parsed as an index expression. We treat all indices after
* the string the same as the end of the string.
*/
- if (idx2 == TCL_INDEX_BEFORE) {
+ if (idx2 == (int)TCL_INDEX_NONE) {
/* [string range $s $first -1] must be empty string */
OP( POP);
PUSH( "");
@@ -992,8 +1046,7 @@ TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1012,7 +1065,7 @@ TclCompileStringReplaceCmd(
* Check for first index known and useful at compile time.
*/
tokenPtr = TokenAfter(valueTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&first) != TCL_OK) {
goto genericReplace;
}
@@ -1021,7 +1074,7 @@ TclCompileStringReplaceCmd(
* Check for last index known and useful at compile time.
*/
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&last) != TCL_OK) {
goto genericReplace;
}
@@ -1040,8 +1093,8 @@ TclCompileStringReplaceCmd(
* compile direct to bytecode implementing the no-op.
*/
- if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */
- || (first == TCL_INDEX_AFTER) /* Know (first > end) */
+ if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */
+ || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */
/*
* Tricky to determine when runtime (last < first) can be
@@ -1049,24 +1102,21 @@ TclCompileStringReplaceCmd(
* cases...
*
* (first <= TCL_INDEX_END) &&
- * (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX END) && (last < first) => ACCEPT
* else => cannot tell REJECT
*/
- || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
+ || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END)
&& (last < first)) /* Know (last < first) */
/*
- * (first == TCL_INDEX_BEFORE) &&
- * (last == TCL_INDEX_AFTER) => (first < last) REJECT
+ * (first == TCL_INDEX_NONE) &&
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else => (first < last) REJECT
*
* else [[first >= TCL_INDEX_START]] &&
- * (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
*/
- || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
+ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)
&& (last < first))) { /* Know (last < first) */
if (parsePtr->numWords == 5) {
tokenPtr = TokenAfter(tokenPtr);
@@ -1095,43 +1145,43 @@ TclCompileStringReplaceCmd(
* (first <= end)
*
* The encoded indices (first <= TCL_INDEX END) and
- * (first == TCL_INDEX_BEFORE) always meets this condition, but
+ * (first == TCL_INDEX_NONE) always meets this condition, but
* any other encoded first index has some list for which it fails.
*
* We also need, second:
*
* (last >= 0)
*
- * The encoded indices (last >= TCL_INDEX_START) and
- * (last == TCL_INDEX_AFTER) always meet this condition but any
- * other encoded last index has some list for which it fails.
+ * The encoded index (last >= TCL_INDEX_START) always meet this
+ * condition but any other encoded last index has some list for
+ * which it fails.
*
* Finally we need, third:
*
* (first <= last)
*
* Considered in combination with the constraints we already have,
- * we see that we can proceed when (first == TCL_INDEX_BEFORE)
- * or (last == TCL_INDEX_AFTER). These also permit simplification
- * of the prefix|replace|suffix construction. The other constraints,
- * though, interfere with getting a guarantee that first <= last.
+ * we see that we can proceed when (first == TCL_INDEX_NONE).
+ * These also permit simplification of the prefix|replace|suffix
+ * construction. The other constraints, though, interfere with
+ * getting a guarantee that first <= last.
*/
- if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
+ if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
/* empty prefix */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP4( REVERSE, 2);
- if (last == TCL_INDEX_AFTER) {
+ if (last == INT_MAX) {
OP( POP); /* Pop original */
} else {
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
}
return TCL_OK;
}
- if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
+ if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
OP44( STR_RANGE_IMM, 0, first-1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1148,19 +1198,19 @@ TclCompileStringReplaceCmd(
* are harmless when they are replaced by another empty string.
*/
- if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
+ if (first == (int)TCL_INDEX_START) {
/* empty prefix - build suffix only */
- if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix too => empty result */
OP( POP); /* Pop original */
PUSH ( "");
return TCL_OK;
}
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
return TCL_OK;
} else {
- if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix - build prefix only */
OP44( STR_RANGE_IMM, 0, first-1);
return TCL_OK;
@@ -1168,7 +1218,7 @@ TclCompileStringReplaceCmd(
OP( DUP);
OP44( STR_RANGE_IMM, 0, first-1);
OP4( REVERSE, 2);
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
@@ -1194,8 +1244,7 @@ TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1222,8 +1271,7 @@ TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1250,8 +1298,7 @@ TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1354,7 +1401,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
StringClassDesc const tclStringClassTable[] = {
@@ -1371,7 +1418,8 @@ StringClassDesc const tclStringClassTable[] = {
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
- {NULL, NULL}
+ {"unicode", Tcl_UniCharIsUnicode},
+ {"", NULL}
};
/*
@@ -1399,8 +1447,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1415,7 +1462,7 @@ TclCompileSubstCmd(
return TCL_ERROR;
}
- objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
TclNewObj(objv[objc]);
@@ -1497,14 +1544,14 @@ TclSubstCompile(
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
int length, literal, catchRange, breakJump;
- char buf[TCL_UTF_MAX] = "";
+ char buf[4] = "";
JumpFixup startFixup, okFixup, returnFixup, breakFixup;
JumpFixup continueFixup, otherFixup, endFixup;
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
- literal = TclRegisterNewLiteral(envPtr,
- tokenPtr->start, tokenPtr->size);
+ literal = TclRegisterLiteral(envPtr,
+ tokenPtr->start, tokenPtr->size, 0);
TclEmitPush(literal, envPtr);
TclAdvanceLines(&bline, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
@@ -1513,7 +1560,7 @@ TclSubstCompile(
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
- literal = TclRegisterNewLiteral(envPtr, buf, length);
+ literal = TclRegisterLiteral(envPtr, buf, length, 0);
TclEmitPush(literal, envPtr);
count++;
continue;
@@ -1732,8 +1779,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1908,10 +1954,10 @@ TclCompileSwitchCmd(
if (maxLen < 2) {
return TCL_ERROR;
}
- bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen);
- bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen);
- bodyLines = ckalloc(sizeof(int) * maxLen);
- bodyContLines = ckalloc(sizeof(int*) * maxLen);
+ bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen);
+ bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen);
+ bodyLines = (int *)ckalloc(sizeof(int) * maxLen);
+ bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen);
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
numWords = 0;
@@ -1949,10 +1995,10 @@ TclCompileSwitchCmd(
}
if (numWords % 2) {
abort:
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyContLines);
+ ckfree(bodyToken);
+ ckfree(bodyTokenArray);
+ ckfree(bodyLines);
+ ckfree(bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
@@ -1970,9 +2016,9 @@ TclCompileSwitchCmd(
* Multi-word definition of patterns & actions.
*/
- bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = ckalloc(sizeof(int) * numWords);
- bodyContLines = ckalloc(sizeof(int*) * numWords);
+ bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords);
+ bodyLines = (int *)ckalloc(sizeof(int) * numWords);
+ bodyContLines = (int **)ckalloc(sizeof(int*) * numWords);
bodyTokenArray = NULL;
for (i=0 ; i<numWords ; i++) {
/*
@@ -2018,10 +2064,10 @@ TclCompileSwitchCmd(
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
- IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
+ IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken,
bodyLines, bodyContLines);
} else {
- IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex,
+ IssueSwitchChainedTests(interp, envPtr, mode, noCase,
numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
@@ -2062,7 +2108,6 @@ IssueSwitchChainedTests(
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
- int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -2092,8 +2137,8 @@ IssueSwitchChainedTests(
contFixIndex = -1;
contFixCount = 0;
- fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
- fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
+ fixupArray = (JumpFixup *)TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
+ fixupTargetArray = (unsigned int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens);
memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
fixupCount = 0;
foundDefault = 0;
@@ -2311,7 +2356,6 @@ static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -2336,10 +2380,10 @@ IssueSwitchJumpTable(
* Start by allocating the jump table itself, plus some workspace.
*/
- jtPtr = ckalloc(sizeof(JumptableInfo));
+ jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
- finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
+ finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
@@ -2503,12 +2547,12 @@ IssueSwitchJumpTable(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
- JumptableInfo *jtPtr = clientData;
- JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo));
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
+ JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
@@ -2525,9 +2569,9 @@ DupJumptableInfo(
static void
FreeJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree(jtPtr);
@@ -2535,12 +2579,12 @@ FreeJumptableInfo(
static void
PrintJumptableInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
+ TCL_UNUSED(ByteCode *),
unsigned int pcOffset)
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
@@ -2548,7 +2592,7 @@ PrintJumptableInfo(
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
if (i++) {
@@ -2564,25 +2608,25 @@ PrintJumptableInfo(
static void
DisassembleJumptableInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_Obj *mapping;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
- int offset;
+ size_t offset;
TclNewObj(mapping);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
- Tcl_NewIntObj(offset));
+ Tcl_NewWideIntObj(offset));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
@@ -2610,8 +2654,7 @@ TclCompileTailcallCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2657,8 +2700,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2689,7 +2731,7 @@ TclCompileThrowCmd(
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
- TclListObjLength(interp, objPtr, &len));
+ TclListObjLengthM(interp, objPtr, &len));
codeIsValid = codeIsList && (len != 0);
if (codeIsValid) {
@@ -2761,8 +2803,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
@@ -2798,12 +2839,12 @@ TclCompileTryCmd(
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
- handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
- matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
+ handlerTokens = (Tcl_Token**)TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
+ matchClauses = (Tcl_Obj **)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);
+ matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
+ resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
+ optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
@@ -2823,7 +2864,7 @@ TclCompileTryCmd(
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
- || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK
+ || TclListObjLengthM(NULL, tmpObj, &objc) != TCL_OK
|| (objc == 0)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
@@ -2866,14 +2907,14 @@ TclCompileTryCmd(
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
+ if (TclListObjGetElementsM(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);
+ const char *varname = TclGetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
@@ -2885,7 +2926,7 @@ TclCompileTryCmd(
}
if (objc == 2) {
int len;
- const char *varname = Tcl_GetStringFromObj(objv[1], &len);
+ const char *varname = TclGetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
@@ -3067,9 +3108,9 @@ IssueTryClausesInstructions(
* Slight overallocation, but reduces size of this function.
*/
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ noError = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
noError[i] = -1;
@@ -3080,7 +3121,7 @@ IssueTryClausesInstructions(
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
- TclListObjLength(NULL, matchClauses[i], &len);
+ TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
@@ -3091,12 +3132,12 @@ IssueTryClausesInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
- notECJumpSource = -1; /* LINT */
+ notECJumpSource = -1;
}
OP( POP);
@@ -3278,8 +3319,8 @@ IssueTryClausesFinallyInstructions(
* Slight overallocation, but reduces size of this function.
*/
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
int noTrapError, trapError;
@@ -3291,7 +3332,7 @@ IssueTryClausesFinallyInstructions(
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
- TclListObjLength(NULL, matchClauses[i], &len);
+ TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
@@ -3302,12 +3343,12 @@ IssueTryClausesFinallyInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
- notECJumpSource = -1; /* LINT */
+ notECJumpSource = -1;
}
OP( POP);
@@ -3574,8 +3615,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3631,7 +3671,7 @@ TclCompileUnsetCmd(
const char *bytes;
int len;
- bytes = Tcl_GetStringFromObj(leadingWord, &len);
+ bytes = TclGetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
@@ -3713,8 +3753,7 @@ 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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3891,8 +3930,7 @@ TclCompileYieldCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
@@ -3934,8 +3972,7 @@ TclCompileYieldToCmd(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -4184,8 +4221,7 @@ int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
@@ -4195,8 +4231,7 @@ int
TclCompileNotOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
@@ -4206,8 +4241,7 @@ int
TclCompileAddOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
@@ -4218,8 +4252,7 @@ int
TclCompileMulOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
@@ -4230,8 +4263,7 @@ int
TclCompileAndOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
@@ -4242,8 +4274,7 @@ int
TclCompileOrOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
@@ -4254,8 +4285,7 @@ int
TclCompileXorOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
@@ -4266,8 +4296,7 @@ int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4297,8 +4326,7 @@ int
TclCompileLshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
@@ -4308,8 +4336,7 @@ int
TclCompileRshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
@@ -4319,8 +4346,7 @@ int
TclCompileModOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
@@ -4330,8 +4356,7 @@ int
TclCompileNeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
@@ -4341,8 +4366,7 @@ int
TclCompileStrneqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
@@ -4352,8 +4376,7 @@ int
TclCompileInOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
@@ -4363,8 +4386,7 @@ int
TclCompileNiOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
@@ -4375,8 +4397,7 @@ int
TclCompileLessOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
@@ -4386,8 +4407,7 @@ int
TclCompileLeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
@@ -4397,8 +4417,7 @@ int
TclCompileGreaterOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
@@ -4408,8 +4427,7 @@ int
TclCompileGeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
@@ -4419,8 +4437,7 @@ int
TclCompileEqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
@@ -4430,19 +4447,57 @@ int
TclCompileStreqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
+
+int
+TclCompileStrLtOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr);
+}
+
+int
+TclCompileStrLeOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr);
+}
+
+int
+TclCompileStrGtOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr);
+}
+
+int
+TclCompileStrGeOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr);
+}
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4487,8 +4542,7 @@ int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index ca9a21a..ded32aa 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -164,6 +164,8 @@ enum Marks {
* "=" is encountered. */
#define INVALID 5 /* A parse error. Used when any punctuation
* appears that's not a supported operator. */
+#define COMMENT 6 /* Comment. Lasts to end of line or end of
+ * expression, whichever comes first. */
/* Leaf lexemes */
@@ -281,7 +283,11 @@ enum Marks {
* parse tree. The sub-expression between
* parens becomes the single argument of the
* matching OPEN_PAREN unary operator. */
-#define END (BINARY | 28)
+#define STR_LT (BINARY | 28)
+#define STR_GT (BINARY | 29)
+#define STR_LEQ (BINARY | 30)
+#define STR_GEQ (BINARY | 31)
+#define END (BINARY | 32)
/* This lexeme represents the end of the
* string being parsed. Treating it as a
* binary operator follows the same logic as
@@ -360,12 +366,14 @@ static const unsigned char prec[] = {
PREC_EQUAL, /* IN_LIST */
PREC_EQUAL, /* NOT_IN_LIST */
PREC_CLOSE_PAREN, /* CLOSE_PAREN */
+ PREC_COMPARE, /* STR_LT */
+ PREC_COMPARE, /* STR_GT */
+ PREC_COMPARE, /* STR_LEQ */
+ PREC_COMPARE, /* STR_GEQ */
PREC_END, /* END */
/* Expansion room for more binary operators */
- 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 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 */
@@ -415,12 +423,14 @@ static const unsigned char instruction[] = {
INST_LIST_IN, /* IN_LIST */
INST_LIST_NOT_IN, /* NOT_IN_LIST */
0, /* CLOSE_PAREN */
+ INST_STR_LT, /* STR_LT */
+ INST_STR_GT, /* STR_GT */
+ INST_STR_LE, /* STR_LEQ */
+ INST_STR_GE, /* STR_GEQ */
0, /* END */
/* Expansion room for more binary operators */
- 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 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 */
@@ -454,7 +464,7 @@ static const unsigned char Lexeme[] = {
INVALID /* FS */, INVALID /* GS */,
INVALID /* RS */, INVALID /* US */,
INVALID /* SPACE */, 0 /* ! or != */,
- QUOTED /* " */, INVALID /* # */,
+ QUOTED /* " */, 0 /* # */,
VARIABLE /* $ */, MOD /* % */,
0 /* & or && */, INVALID /* ' */,
OPEN_PAREN /* ( */, CLOSE_PAREN /* ) */,
@@ -623,7 +633,7 @@ ParseExpr(
TclParseInit(interp, start, numBytes, parsePtr);
- nodes = attemptckalloc(nodesAvailable * sizeof(OpNode));
+ nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
errCode = "NOMEM";
@@ -666,9 +676,10 @@ ParseExpr(
OpNode *newPtr = NULL;
do {
- if (size <= UINT_MAX/sizeof(OpNode)) {
- newPtr = attemptckrealloc(nodes, size * sizeof(OpNode));
- }
+ if (size <= UINT_MAX/sizeof(OpNode)) {
+ newPtr = (OpNode *) attemptckrealloc(nodes,
+ size * sizeof(OpNode));
+ }
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
if (newPtr == NULL) {
@@ -700,6 +711,10 @@ ParseExpr(
int b;
switch (lexeme) {
+ case COMMENT:
+ start += scanned;
+ numBytes -= scanned;
+ continue;
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
scanned, start);
@@ -734,6 +749,32 @@ ParseExpr(
} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
lexeme = BOOLEAN;
} else {
+ /*
+ * Tricky case: see test expr-62.10
+ */
+
+ int scanned2 = scanned;
+ do {
+ scanned2 += TclParseAllWhiteSpace(
+ start + scanned2, numBytes - scanned2);
+ scanned2 += ParseLexeme(
+ start + scanned2, numBytes - scanned2, &lexeme,
+ NULL);
+ } while (lexeme == COMMENT);
+ if (lexeme == OPEN_PAREN) {
+ /*
+ * Actually a function call, but with obscuring
+ * comments. Skip to the start of the parentheses.
+ * Note that we assume that open parentheses are one
+ * byte long.
+ */
+
+ lexeme = FUNCTION;
+ Tcl_ListObjAppendElement(NULL, funcList, literal);
+ scanned = scanned2 - 1;
+ break;
+ }
+
Tcl_DecrRefCount(literal);
msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
(scanned < limit) ? scanned : limit - 3, start,
@@ -911,7 +952,7 @@ ParseExpr(
break;
case SCRIPT: {
- Tcl_Parse *nestedPtr =
+ Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
@@ -1759,7 +1800,7 @@ ConvertTreeToTokens(
/*
* All the Tcl_Tokens allocated and filled belong to
- * this subexpresion. The first token is the leading
+ * this subexpression. The first token is the leading
* TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
* are its components.
*/
@@ -1830,15 +1871,15 @@ Tcl_ParseExpr(
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList; /* List to hold the literals. */
Tcl_Obj *funcList; /* List to hold the functon names. */
- Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
+ TclNewObj(litList);
+ TclNewObj(funcList);
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
}
- TclNewObj(litList);
- TclNewObj(funcList);
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
@@ -1886,8 +1927,8 @@ ParseLexeme(
storage, if non-NULL. */
{
const char *end;
- int scanned;
- Tcl_UniChar ch = 0;
+ int scanned, size;
+ int ch;
Tcl_Obj *literal = NULL;
unsigned char byte;
@@ -1901,6 +1942,16 @@ ParseLexeme(
return 1;
}
switch (byte) {
+ case '#':
+ /*
+ * Scan forward over the comment contents.
+ */
+ for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) {
+ byte = UCHAR(start[size]);
+ }
+ *lexemePtr = COMMENT;
+ return size - (byte == '\n');
+
case '*':
if ((numBytes > 1) && (start[1] == '*')) {
*lexemePtr = EXPON;
@@ -2003,6 +2054,35 @@ ParseLexeme(
return 2;
}
}
+ break;
+
+ case 'l':
+ if ((numBytes > 1)
+ && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) {
+ switch (start[1]) {
+ case 't':
+ *lexemePtr = STR_LT;
+ return 2;
+ case 'e':
+ *lexemePtr = STR_LEQ;
+ return 2;
+ }
+ }
+ break;
+
+ case 'g':
+ if ((numBytes > 1)
+ && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) {
+ switch (start[1]) {
+ case 't':
+ *lexemePtr = STR_GT;
+ return 2;
+ case 'e':
+ *lexemePtr = STR_GEQ;
+ return 2;
+ }
+ }
+ break;
}
TclNewObj(literal);
@@ -2029,7 +2109,7 @@ ParseLexeme(
* Example: Inf + luence + () becomes a valid function call.
* [Bug 3401704]
*/
- if (literal->typePtr == &tclDoubleType) {
+ if (TclHasInternalRep(literal, &tclDoubleType)) {
const char *p = start;
while (p < end) {
@@ -2066,13 +2146,13 @@ ParseLexeme(
if (!TclIsBareword(*start) || *start == '_') {
if (Tcl_UtfCharComplete(start, numBytes)) {
- scanned = TclUtfToUniChar(start, &ch);
+ scanned = TclUtfToUCS4(start, &ch);
} else {
- char utfBytes[TCL_UTF_MAX];
+ char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
- scanned = TclUtfToUniChar(utfBytes, &ch);
+ scanned = TclUtfToUCS4(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
@@ -2119,9 +2199,9 @@ TclCompileExpr(
int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
- Tcl_Obj *litList; /* List to hold the literals */
- Tcl_Obj *funcList; /* List to hold the functon names*/
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Obj *litList; /* List to hold the literals */
+ Tcl_Obj *funcList; /* List to hold the functon names*/
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code;
@@ -2143,8 +2223,8 @@ TclCompileExpr(
TclAdvanceLines(&envPtr->line, script,
script + TclParseAllWhiteSpace(script, numBytes));
- TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
- TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
+ TclListObjGetElementsM(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
+ TclListObjGetElementsM(NULL, funcList, &objc, &funcObjv);
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
parsePtr->tokenPtr, envPtr, optimize);
} else {
@@ -2186,29 +2266,25 @@ ExecConstantExprTree(
CompileEnv *envPtr;
ByteCode *byteCodePtr;
int code;
- Tcl_Obj *byteCodeObj;
NRE_callback *rootPtr = TOP_CB(interp);
- TclNewObj(byteCodeObj);
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
* bytecode, so there's no need to tend to TIP 280 issues.
*/
- envPtr = TclStackAlloc(interp, sizeof(CompileEnv));
+ envPtr = (CompileEnv *)TclStackAlloc(interp, sizeof(CompileEnv));
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
TclEmitOpcode(INST_DONE, envPtr);
- Tcl_IncrRefCount(byteCodeObj);
- TclInitByteCodeObj(byteCodeObj, envPtr);
+ byteCodePtr = TclInitByteCode(envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
- Tcl_DecrRefCount(byteCodeObj);
+ TclReleaseByteCode(byteCodePtr);
return code;
}
@@ -2276,9 +2352,9 @@ CompileExprTree(
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
- TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
+ TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
- Tcl_DStringLength(&cmdName)), envPtr);
+ Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
/*
@@ -2293,13 +2369,13 @@ CompileExprTree(
break;
}
case QUESTION:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
@@ -2312,7 +2388,7 @@ CompileExprTree(
break;
case AND:
case OR:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
@@ -2385,8 +2461,8 @@ CompileExprTree(
pc1 = CurrentOffset(envPtr);
TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
: INST_JUMP_TRUE1, 0, envPtr);
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr);
pc2 = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
@@ -2395,8 +2471,8 @@ CompileExprTree(
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
pc2 += 3;
}
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
envPtr->codeStart + pc2 + 1);
convert = 0;
@@ -2430,7 +2506,7 @@ CompileExprTree(
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
- int idx = TclRegisterNewLiteral(envPtr, bytes, length);
+ int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
@@ -2485,11 +2561,13 @@ CompileExprTree(
* already, then use it to share via the literal table.
*/
- if (objPtr->bytes) {
+ if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
+ int numBytes;
+ const char *bytes
+ = Tcl_GetStringFromObj(objPtr, &numBytes);
- idx = TclRegisterNewLiteral(envPtr, objPtr->bytes,
- objPtr->length);
+ idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
@@ -2543,7 +2621,7 @@ TclSingleOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
OpNode nodes[2];
Tcl_Obj *const *litObjv = objv + 1;
@@ -2575,7 +2653,7 @@ TclSingleOpCmd(
*
* TclSortingOpCmd --
* Implements the commands:
- * <, <=, >, >=, ==, eq
+ * <, <=, >, >=, ==, eq, lt, le, gt, ge
* 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.
@@ -2601,10 +2679,10 @@ TclSortingOpCmd(
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
- TclOpCmdClientData *occdPtr = clientData;
- Tcl_Obj **litObjv = TclStackAlloc(interp,
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
+ Tcl_Obj **litObjv = (Tcl_Obj **)TclStackAlloc(interp,
2 * (objc-2) * sizeof(Tcl_Obj *));
- OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
+ OpNode *nodes = (OpNode *)TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
unsigned char lexeme;
int i, lastAnd = 1;
Tcl_Obj *const *litObjPtrPtr = litObjv;
@@ -2676,12 +2754,12 @@ TclVariadicOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
if (objc < 2) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity));
return TCL_OK;
}
@@ -2709,7 +2787,7 @@ TclVariadicOpCmd(
nodes[1].p.parent = 0;
} else {
if (lexeme == DIVIDE) {
- litObjv[0] = Tcl_NewDoubleObj(1.0);
+ TclNewDoubleObj(litObjv[0], 1.0);
} else {
TclNewIntObj(litObjv[0], occdPtr->i.identity);
}
@@ -2731,7 +2809,7 @@ TclVariadicOpCmd(
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
- OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
+ OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
int i, lastOp = OT_LITERAL;
nodes[0].lexeme = START;
@@ -2795,7 +2873,7 @@ TclNoIdentOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index bffe7f8..c10145c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -5,8 +5,8 @@
* commands (like quoted strings or nested sub-commands) into a sequence
* of instructions ("bytecodes").
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 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.
@@ -659,6 +659,30 @@ InstructionDesc const tclInstructionTable[] = {
* 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
* Stack: ... => ... time */
+ {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* The top word is the default, the next op4 words (min 1) are a key
+ * path into the dictionary just below the keys on the stack, and all
+ * those values are replaced by the value read out of that key-path
+ * (like [dict get]) except if there is no such key, when instead the
+ * default is pushed instead.
+ * Stack: ... dict key1 ... keyN default => ... value */
+
+ {"strlt", 1, -1, 0, {OPERAND_NONE}},
+ /* String Less: push (stknext < stktop) */
+ {"strgt", 1, -1, 0, {OPERAND_NONE}},
+ /* String Greater: push (stknext > stktop) */
+ {"strle", 1, -1, 0, {OPERAND_NONE}},
+ /* String Less or equal: push (stknext <= stktop) */
+ {"strge", 1, -1, 0, {OPERAND_NONE}},
+ /* String Greater or equal: push (stknext >= stktop) */
+ {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}},
+ /* Operands: number of arguments, flags
+ * flags: Combination of TCL_LREPLACE4_* flags
+ * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj
+ * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not
+ * set in flags.
+ */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -666,6 +690,7 @@ InstructionDesc const tclInstructionTable[] = {
* Prototypes for procedures defined later in this file:
*/
+static void CleanupByteCode(ByteCode *codePtr);
static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
@@ -679,8 +704,8 @@ static void EnterCmdStartData(CompileEnv *envPtr,
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
-static int IsCompactibleCompileEnv(Tcl_Interp *interp,
- CompileEnv *envPtr);
+static int IsCompactibleCompileEnv(CompileEnv *envPtr);
+static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
@@ -693,14 +718,14 @@ static void StartExpanding(CompileEnv *envPtr);
* commands.
*/
static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
- Tcl_Token *tokenPtr, const char *cmd, int len,
+ Tcl_Token *tokenPtr, const char *cmd,
int numWords, int line, int *clNext, int **lines,
CompileEnv *envPtr);
static void ReleaseCmdWordData(ExtCmdLoc *eclPtr);
/*
- * The structure below defines the bytecode Tcl object type by means of
- * procedures that can be invoked by generic object code.
+ * tclByteCodeType provides the standard type management procedures for the
+ * bytecode type.
*/
const Tcl_ObjType tclByteCodeType = {
@@ -712,8 +737,8 @@ const Tcl_ObjType tclByteCodeType = {
};
/*
- * The structure below defines a bytecode Tcl object type to hold the
- * compiled bytecode for the [subst]itution of Tcl values.
+ * subtCodeType provides the standard type managemnt procedures for the
+ * substcode type, which represents substiution within a Tcl value.
*/
static const Tcl_ObjType substCodeType = {
@@ -723,13 +748,14 @@ static const Tcl_ObjType substCodeType = {
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2
/*
* Helper macros.
*/
#define TclIncrUInt4AtPtr(ptr, delta) \
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr))
/*
*----------------------------------------------------------------------
@@ -737,16 +763,14 @@ static const Tcl_ObjType substCodeType = {
* TclSetByteCodeFromAny --
*
* Part of the bytecode Tcl object type implementation. Attempts to
- * generate an byte code internal form for the Tcl object "objPtr" by
- * compiling its string representation. This function also takes a hook
- * procedure that will be invoked to perform any needed post processing
- * on the compilation results before generating byte codes. interp is
+ * compile the string representation of the objPtr into bytecode. Accepts
+ * a hook routine that is invoked to perform any needed post-processing on
+ * the compilation results before generating byte codes. interp is the
* compilation context and may not be NULL.
*
* Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result.
+ * A standard Tcl object result. If an error occurs during compilation, an
+ * error message is left in the interpreter's result.
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
@@ -763,12 +787,13 @@ TclSetByteCodeFromAny(
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
- ClientData clientData) /* Hook procedure private data. */
+ void *clientData) /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- int length, result = TCL_OK;
+ int length;
+ int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -776,7 +801,7 @@ TclSetByteCodeFromAny(
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
- (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
@@ -786,7 +811,7 @@ TclSetByteCodeFromAny(
stringPtr = TclGetStringFromObj(objPtr, &length);
/*
- * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
+ * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
@@ -795,15 +820,14 @@ TclSetByteCodeFromAny(
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.
+ * Make available to the compilation environment any data about invisible
+ * continuation lines for the script.
*
* 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(),
- * found in this file. The "lineCLPtr" hashtable is managed in the file
- * "tclObj.c".
+ * structure as well. To ensure that the latter doesn't happen set a lock
+ * on it, which is released in TclFreeCompileEnv(). The "lineCLPtr"
+ * hashtable tclObj.c.
*/
clLocPtr = TclContinuationsGet(objPtr);
@@ -814,7 +838,7 @@ TclSetByteCodeFromAny(
TclCompileScript(interp, stringPtr, length, &compEnv);
/*
- * Successful compilation. Add a "done" instruction at the end.
+ * Compilation succeeded. Add a "done" instruction at the end.
*/
TclEmitOpcode(INST_DONE, &compEnv);
@@ -822,14 +846,14 @@ TclSetByteCodeFromAny(
/*
* Check for optimizations!
*
- * Test if the generated code is free of most hazards; if so, recompile
- * but with generation of INST_START_CMD disabled. This produces somewhat
- * faster code in some cases, and more compact code in more.
+ * If the generated code is free of most hazards, recompile with generation
+ * of INST_START_CMD disabled to produce code that more compact in many
+ * cases, and also sometimes more performant.
*/
if (Tcl_GetParent(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
- && IsCompactibleCompileEnv(interp, &compEnv)) {
+ && IsCompactibleCompileEnv(&compEnv)) {
TclFreeCompileEnv(&compEnv);
iPtr->compiledProcPtr = procPtr;
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
@@ -854,7 +878,7 @@ TclSetByteCodeFromAny(
}
/*
- * Invoke the compilation hook procedure if one exists.
+ * Invoke the compilation hook procedure if there is one.
*/
if (hookProc) {
@@ -863,7 +887,7 @@ TclSetByteCodeFromAny(
/*
* Change the object into a ByteCode object. Ownership of the literal
- * objects and aux data items is given to the ByteCode object.
+ * objects and aux data items passes to the ByteCode object.
*/
#ifdef TCL_COMPILE_DEBUG
@@ -871,7 +895,7 @@ TclSetByteCodeFromAny(
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
- TclInitByteCodeObj(objPtr, &compEnv);
+ (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
@@ -894,12 +918,12 @@ TclSetByteCodeFromAny(
* compiling its string representation.
*
* Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result unless "interp" is NULL.
+ * A standard Tcl object result. If an error occurs during compilation and
+ * "interp" is not null, an error message is left in the interpreter's
+ * result.
*
* Side effects:
- * Frees the old internal representation. If no error occurs, then the
+ * Frees the old internal representation. If no error occurs then the
* compiled code is stored as "objPtr"s bytecode representation. Also, if
* debugging, initializes the "tcl_traceCompile" Tcl variable used to
* trace compilations.
@@ -911,7 +935,7 @@ static int
SetByteCodeFromAny(
Tcl_Interp *interp, /* The interpreter for which the code is being
* compiled. Must not be NULL. */
- Tcl_Obj *objPtr) /* The object to make a ByteCode object. */
+ Tcl_Obj *objPtr) /* The object to compile to bytecode */
{
if (interp == NULL) {
return TCL_ERROR;
@@ -925,9 +949,9 @@ SetByteCodeFromAny(
* DupByteCodeInternalRep --
*
* Part of the bytecode Tcl object type implementation. However, it does
- * not copy the internal representation of a bytecode Tcl_Obj, but
- * instead leaves the new object untyped (with a NULL type pointer).
- * Code will be compiled for the new object only if necessary.
+ * not copy the internal representation of a bytecode Tcl_Obj, instead
+ * assigning NULL to the type pointer of the new object. Code is compiled
+ * for the new object only if necessary.
*
* Results:
* None.
@@ -940,8 +964,8 @@ SetByteCodeFromAny(
static void
DupByteCodeInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ TCL_UNUSED(Tcl_Obj *) /*srcPtr*/,
+ TCL_UNUSED(Tcl_Obj *) /*copyPtr*/)
{
return;
}
@@ -959,9 +983,9 @@ DupByteCodeInternalRep(
* None.
*
* Side effects:
- * The bytecode 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.
+ * The bytecode object's internal rep is invalidated and its code is freed
+ * unless the code is actively being executed, in which case cleanup is
+ * delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
@@ -970,35 +994,54 @@ static void
FreeByteCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
*
- * TclCleanupByteCode --
+ * TclReleaseByteCode --
*
- * This procedure does all the real work of freeing up a bytecode
- * object's ByteCode structure. It's called only when the structure's
- * reference count becomes zero.
+ * Does all the real work of freeing up a bytecode object's ByteCode
+ * structure. Called only when the structure's reference count
+ * is zero.
*
* Results:
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets its type NULL
- * Also releases its literals and frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type to
+ * NULL. Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
-TclCleanupByteCode(
+TclPreserveByteCode(
+ ByteCode *codePtr)
+{
+ codePtr->refCount++;
+}
+
+void
+TclReleaseByteCode(
+ ByteCode *codePtr)
+{
+ if (codePtr->refCount-- > 1) {
+ return;
+ }
+
+ /* Just dropped to refcount==0. Clean up. */
+ CleanupByteCode(codePtr);
+}
+
+static void
+CleanupByteCode(
ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
@@ -1018,7 +1061,7 @@ TclCleanupByteCode(
statsPtr = &iPtr->stats;
statsPtr->numByteCodesFreed++;
- statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
+ statsPtr->currentSrcBytes -= (double)codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
@@ -1049,8 +1092,8 @@ TclCleanupByteCode(
/*
* A single heap object holds the ByteCode structure and its code, object,
* command location, and auxiliary data arrays. This means we only need to
- * 1) decrement the ref counts of the LiteralEntry's in its literal array,
- * 2) call the free procs for the auxiliary data items, 3) free the
+ * 1) decrement the ref counts of each LiteralEntry in the literal array,
+ * 2) call the free procedures for the auxiliary data items, 3) free the
* localCache if it is unused, and finally 4) free the ByteCode
* structure's heap object.
*
@@ -1059,11 +1102,11 @@ TclCleanupByteCode(
* the global literal table. They instead maintain private references to
* their literals which must be decremented.
*
- * In order to insure a proper and efficient cleanup of the literal array
- * when it contains non-shared literals [Bug 983660], we also distinguish
- * the case of an interpreter being deleted (signaled by interp == NULL).
+ * In order to ensure proper and efficient cleanup of the literal array
+ * when it contains non-shared literals [Bug 983660], distinguish the case
+ * of an interpreter being deleted, which is signaled by interp == NULL.
* Also, as the interp deletion will remove the global literal table
- * anyway, we avoid the extra cost of updating it for each literal being
+ * anyway, avoid the extra cost of updating it for each literal being
* released.
*/
@@ -1095,9 +1138,9 @@ TclCleanupByteCode(
}
/*
- * TIP #280. Release the location data associated with this byte code
- * structure, if any. NOTE: The interp we belong to may be gone already,
- * and the data with it.
+ * TIP #280. Release the location data associated with this bytecode
+ * structure, if any. The associated interp may be gone already, and the
+ * data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
@@ -1107,12 +1150,12 @@ TclCleanupByteCode(
(char *) codePtr);
if (hePtr) {
- ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
+ ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
- if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
+ if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
@@ -1125,15 +1168,14 @@ TclCleanupByteCode(
*
* IsCompactibleCompileEnv --
*
- * Checks to see if we may apply some basic compaction optimizations to a
- * piece of bytecode. Idempotent.
+ * Determines whether some basic compaction optimizations may be applied
+ * to a piece of bytecode. Idempotent.
*
* ---------------------------------------------------------------------
*/
static int
IsCompactibleCompileEnv(
- Tcl_Interp *interp,
CompileEnv *envPtr)
{
unsigned char *pc;
@@ -1141,7 +1183,7 @@ IsCompactibleCompileEnv(
/*
* Special: procedures in the '::tcl' namespace (or its children) are
- * considered to be well-behaved and so can have compaction applied even
+ * considered to be well-behaved, so compaction can be applied to them even
* if it would otherwise be invalid.
*/
@@ -1157,10 +1199,10 @@ IsCompactibleCompileEnv(
/*
* Go through and ensure that no operation involved can cause a desired
- * change of bytecode sequence during running. This comes down to ensuring
- * that there are no mapped variables (due to traces) or calls to external
- * commands (traces, [uplevel] trickery). This is actually a very
- * conservative check; it turns down a lot of code that is OK in practice.
+ * change of bytecode sequence during its execution. This comes down to
+ * ensuring that there are no mapped variables (due to traces) or calls to
+ * external commands (traces, [uplevel] trickery). This is actually a very
+ * conservative check. It turns down a lot of code that is OK in practice.
*/
for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
@@ -1196,8 +1238,8 @@ IsCompactibleCompileEnv(
*
* Tcl_SubstObj --
*
- * This function performs the substitutions specified on the given string
- * as described in the user documentation for the "subst" Tcl command.
+ * Performs substitutions on the given string as described in the user
+ * documentation for "subst".
*
* Results:
* A Tcl_Obj* containing the substituted string, or NULL to indicate that
@@ -1229,14 +1271,14 @@ Tcl_SubstObj(
*
* Tcl_NRSubstObj --
*
- * Request substitution of a Tcl value by the NR stack.
+ * Adds substitution within the value of objPtr to the NR execution stack.
*
* Results:
- * Returns TCL_OK.
+ * 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
+ * governed by flags, adds a callback to the NR execution stack to execute
* the bytecode and store the result in the interp.
*
*----------------------------------------------------------------------
@@ -1260,13 +1302,11 @@ Tcl_NRSubstObj(
*
* CompileSubstObj --
*
- * Compile a Tcl value into ByteCode implementing its substitution, as
- * governed by flags.
+ * Compiles a value into bytecode that performs substitution within the
+ * value, 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.
+ * A (ByteCode *) is pointing to the resulting ByteCode.
*
* Side effects:
* The Tcl_ObjType of objPtr is changed to the "substcode" type, and the
@@ -1286,24 +1326,26 @@ CompileSubstObj(
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr = NULL;
- if (objPtr->typePtr == &substCodeType) {
+ ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2)
+ if (flags != PTR2INT(SubstFlags(objPtr))
|| ((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| (codePtr->localCachePtr !=
iPtr->varFramePtr->localCachePtr)) {
- FreeSubstCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &substCodeType) {
+ if (codePtr == NULL) {
CompileEnv compEnv;
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+ const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
@@ -1311,13 +1353,10 @@ CompileSubstObj(
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &substCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
+ SubstFlags(objPtr) = INT2PTR(flags);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1337,9 +1376,9 @@ CompileSubstObj(
*
* 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.
+ * Part of the "substcode" Tcl object type implementation. Frees the
+ * storage associated with the substcode internal representation of a
+ * Tcl_Obj unless its code is actively being executed.
*
* Results:
* None.
@@ -1356,12 +1395,12 @@ static void
FreeSubstCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
static void
@@ -1374,14 +1413,14 @@ ReleaseCmdWordData(
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);
}
- ckfree((char *) eclPtr);
+ ckfree(eclPtr);
}
/*
@@ -1460,7 +1499,7 @@ TclInitCompileEnv(
* non-compiling evaluator
*/
- envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
+ envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
@@ -1516,7 +1555,7 @@ TclInitCompileEnv(
* ...) which may make change the type as well.
*/
- CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
int pc = 0;
*ctxPtr = *invoker;
@@ -1593,14 +1632,14 @@ TclInitCompileEnv(
*
* TclFreeCompileEnv --
*
- * Free the storage allocated in a CompileEnv compilation environment
+ * Frees the storage allocated in a CompileEnv compilation environment
* structure.
*
* Results:
* None.
*
* Side effects:
- * Allocated storage in the CompileEnv structure is freed. Note that its
+ * Allocated storage in the CompileEnv structure is freed, although its
* local literal table is not deleted and its literal objects are not
* released. In addition, storage referenced by its auxiliary data items
* is not freed. This is done so that, when compilation is successful,
@@ -1671,10 +1710,11 @@ TclFreeCompileEnv(
*
* TclWordKnownAtCompileTime --
*
- * Test whether the value of a token is completely known at compile time.
+ * Determines whether the value of a token is completely known at compile
+ * time.
*
* Results:
- * Returns true if the tokenPtr argument points to a word value that is
+ * True if the tokenPtr argument points to a word value that is
* completely known at compile time. Generally, values that are known at
* compile time can be compiled to their values, while values that cannot
* be known until substitution at runtime must be compiled to bytecode
@@ -1723,7 +1763,7 @@ TclWordKnownAtCompileTime(
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
- char utfBuf[TCL_UTF_MAX] = "";
+ char utfBuf[4] = "";
int length = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfBuf);
@@ -1751,12 +1791,12 @@ TclWordKnownAtCompileTime(
*
* TclCompileScript --
*
- * Compile a Tcl script in a string.
+ * Compiles a Tcl script in a string.
*
* Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
+ *
+ * A standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
*
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
@@ -1785,20 +1825,20 @@ CompileCmdLiteral(
Tcl_Obj *cmdObj,
CompileEnv *envPtr)
{
- int numBytes;
const char *bytes;
Command *cmdPtr;
int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
+ int numBytes;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
- cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags);
+ bytes = TclGetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
- if (cmdPtr) {
+ if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
@@ -1813,7 +1853,8 @@ TclCompileInvocation(
CompileEnv *envPtr)
{
DefineLineInformation;
- int wordIdx = 0, depth = TclGetStackDepth(envPtr);
+ int wordIdx = 0;
+ int depth = TclGetStackDepth(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
@@ -1831,8 +1872,8 @@ TclCompileInvocation(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1881,8 +1922,8 @@ CompileExpanded(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1893,14 +1934,14 @@ CompileExpanded(
/*
* The stack depth during argument expansion can only be managed at
* runtime, as the number of elements in the expanded lists is not known
- * at compile time. We adjust here the stack depth estimate so that it is
+ * at compile time. Adjust the stack depth estimate here so that it is
* correct after the command with expanded arguments returns.
*
* The end effect of this command's invocation is that all the words of
- * the command are popped from the stack, and the result is pushed: the
+ * the command are popped from the stack and the result is pushed: The
* stack top changes by (1-wordIdx).
*
- * Note that the estimates are not correct while the command is being
+ * The estimates are not correct while the command is being
* prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
*/
@@ -1920,16 +1961,16 @@ CompileCmdCompileProc(
int depth = TclGetStackDepth(envPtr);
/*
- * Emit of the INST_START_CMD instruction is controlled by the value of
+ * Emission of the INST_START_CMD instruction is controlled by the value of
* envPtr->atCmdStart:
*
- * atCmdStart == 2 : We are not using the INST_START_CMD instruction.
- * atCmdStart == 1 : INST_START_CMD was the last instruction emitted.
- * : We do not need to emit another. Instead we
- * : increment the number of cmds started at it (except
- * : for the special case at the start of a script.)
- * atCmdStart == 0 : The last instruction was something else. We need
- * : to emit INST_START_CMD here.
+ * atCmdStart == 2 : Don't use the INST_START_CMD instruction.
+ * atCmdStart == 1 : INST_START_CMD was the last instruction emitted,
+ * : so no need to emit another. Instead
+ * : increment the number of cmds started at it, except
+ * : for the special case at the start of a script.
+ * atCmdStart == 0 : The last instruction was something else.
+ * : Emit INST_START_CMD here.
*/
switch (envPtr->atCmdStart) {
@@ -1952,7 +1993,7 @@ CompileCmdCompileProc(
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) {
if (incrOffset >= 0) {
/*
- * We successfully compiled a command. Increment the number of
+ * Command compiled succesfully. Increment the number of
* commands that start at the currently active INST_START_CMD.
*/
@@ -2010,25 +2051,25 @@ CompileCommandTokens(
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
- TclNewObj(cmdObj);
assert (parsePtr->numWords > 0);
/* Pre-Compile */
+ TclNewObj(cmdObj);
envPtr->numCommands++;
EnterCmdStartData(envPtr, cmdIdx,
parsePtr->commandStart - envPtr->source, startCodeOffset);
/*
* TIP #280. Scan the words and compute the extended location information.
- * The map first contain full per-word line information for use by the
+ * At first the map first contains full per-word line information for use by the
* compiler. This is later replaced by a reduced form which signals
* non-literal words, stored in 'wlines'.
*/
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ parsePtr->numWords, cmdLine,
clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
@@ -2063,7 +2104,7 @@ CompileCommandTokens(
}
}
- /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */
+ /* If cmdPtr != NULL, try to call cmdPtr->compileProc */
if (cmdPtr) {
code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
}
@@ -2090,8 +2131,8 @@ CompileCommandTokens(
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
/*
- * TIP #280: Free full form of per-word line data and insert the reduced
- * form now
+ * TIP #280: Free the full form of per-word line data and insert the
+ * reduced form now.
*/
envPtr->line = cmdLine;
@@ -2129,10 +2170,10 @@ TclCompileScript(
}
/*
* Check depth to avoid overflow of the C execution stack by too many
- * nested calls of TclCompileScript (considering interp recursionlimit).
- * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
- * during "mixed" evaluation and compilation process (nested eval+compile)
- * and is good enough for default recursionlimit (1000).
+ * nested calls of TclCompileScript, considering interp recursionlimit.
+ * Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
+ * limit during "mixed" evaluation and compilation process (nested
+ * eval+compile) and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -2150,7 +2191,7 @@ TclCompileScript(
* many nested compilations (body enclosed in body) can cause abnormal
* program termination with a stack overflow exception, bug [fec0c17d39].
*/
- Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = (Tcl_Parse *)ckalloc(sizeof(Tcl_Parse));
do {
const char *next;
@@ -2275,8 +2316,8 @@ TclCompileScript(
*
* TclCompileTokens --
*
- * Given an array of tokens parsed from a Tcl command (e.g., the tokens
- * that make up a word) this procedure emits instructions to evaluate the
+ * Given an array of tokens parsed from a Tcl command, e.g. the tokens
+ * that make up a word, emits instructions to evaluate the
* tokens and concatenate their values to form a single result value on
* the interpreter's runtime evaluation stack.
*
@@ -2298,8 +2339,8 @@ TclCompileVarSubst(
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
- int nameBytes = tokenPtr[1].size;
- int i, localVar, localVarName = 1;
+ int i, localVar, nameBytes = tokenPtr[1].size;
+ int localVarName = 1;
/*
* Determine how the variable name should be handled: if it contains any
@@ -2326,7 +2367,7 @@ TclCompileVarSubst(
* of local variables in a procedure frame.
*/
- localVar = -1;
+ localVar = TCL_INDEX_NONE;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
}
@@ -2372,8 +2413,9 @@ TclCompileTokens(
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
- char buffer[TCL_UTF_MAX] = "";
- int i, numObjsToConcat, length, adjust;
+ char buffer[4] = "";
+ int i, numObjsToConcat, adjust;
+ int length;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
@@ -2381,18 +2423,16 @@ TclCompileTokens(
int depth = TclGetStackDepth(envPtr);
/*
- * 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.
+ * if this is actually a literal, handle continuation lines by
+ * preallocating a small table to store the locations of any continuation
+ * lines we find in this literal. 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 run-time processing.
+ * Note: In contrast with the analagous code in 'TclSubstTokens()' the
+ * 'adjust' variable seems unneeded here. The code which merges
+ * continuation line information of multiple words which concat'd at
+ * runtime also seems unneeded. 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;
@@ -2408,7 +2448,7 @@ TclCompileTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2428,18 +2468,17 @@ TclCompileTokens(
Tcl_DStringAppend(&textBuffer, buffer, length);
/*
- * If the backslash sequence we found is in a literal, and
- * represented a continuation line, we compute and store its
+ * If the identified backslash sequence is in a literal and
+ * represented a continuation line, compute and store its
* location (as char offset to the beginning of the _result_
* script). We may have to extend the table of locations.
*
- * Note that the continuation line information is relevant even if
- * the word we are processing is not a literal, as it can affect
- * nested commands. See the branch for TCL_TOKEN_COMMAND below,
- * where the adjustment we are tracking here is taken into
- * account. The good thing is that we do not need a table of
- * everything, just the number of lines we have to add as
- * correction.
+ * The continuation line information is relevant even if the word
+ * being processed is not a literal, as it can affect nested
+ * commands. See the branch below for TCL_TOKEN_COMMAND, where the
+ * adjustment being tracked here is taken into account. The good
+ * thing is a table of everything is not needed, just the number of
+ * lines to to add as correction.
*/
if ((length == 1) && (buffer[0] == ' ') &&
@@ -2449,7 +2488,7 @@ TclCompileTokens(
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = ckrealloc(clPosition,
+ clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
@@ -2565,13 +2604,13 @@ TclCompileTokens(
* TclCompileCmdWord --
*
* Given an array of parse tokens for a word containing one or more Tcl
- * commands, emit inline instructions to execute them. This procedure
- * differs from TclCompileTokens in that a simple word such as a loop
- * body enclosed in braces is not just pushed as a string, but is itself
- * parsed into tokens and compiled.
+ * commands, emits inline instructions to execute them. In contrast with
+ * TclCompileTokens, a simple word such as a loop body enclosed in braces
+ * is not just pushed as a string, but is itself parsed into tokens and
+ * compiled.
*
* Results:
- * The return value is a standard Tcl result. If an error occurs, an
+ * A standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
@@ -2591,16 +2630,16 @@ TclCompileCmdWord(
{
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
/*
- * Handle the common case: if there is a single text token, compile it
+ * The common case that there is a single text token. Compile it
* into an inline sequence of instructions.
*/
TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
} else {
/*
- * Multiple tokens or the single token involves substitutions. Emit
- * instructions to invoke the eval command procedure at runtime on the
- * result of evaluating the tokens.
+ * Either there are multiple tokens, or the single token involves
+ * substitutions. Emit instructions to invoke the eval command
+ * procedure at runtime on the result of evaluating the tokens.
*/
TclCompileTokens(interp, tokenPtr, count, envPtr);
@@ -2614,13 +2653,12 @@ TclCompileCmdWord(
* TclCompileExprWords --
*
* Given an array of parse tokens representing one or more words that
- * contain a Tcl expression, emit inline instructions to execute the
- * expression. This procedure differs from TclCompileExpr in that it
- * supports Tcl's two-level substitution semantics for expressions that
- * appear as command words.
+ * contain a Tcl expression, emits inline instructions to execute the
+ * expression. In contrast with TclCompileExpr, supports Tcl's two-level
+ * substitution semantics for an expression that appears as command words.
*
* Results:
- * The return value is a standard Tcl result. If an error occurs, an
+ * A standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
@@ -2682,10 +2720,10 @@ TclCompileExprWords(
*
* TclCompileNoOp --
*
- * Function called to compile no-op's
+ * Compiles no-op's
*
* Results:
- * The return value is TCL_OK, indicating successful compilation.
+ * TCL_OK if completion was successful.
*
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
@@ -2700,8 +2738,7 @@ TclCompileNoOp(
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 definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
@@ -2725,14 +2762,14 @@ TclCompileNoOp(
*
* TclInitByteCodeObj --
*
- * Create a ByteCode structure and initialize it from a CompileEnv
+ * Creates a ByteCode structure and initializes it from a CompileEnv
* compilation environment structure. The ByteCode structure is smaller
* and contains just that information needed to execute the bytecode
* instructions resulting from compiling a Tcl script. The resulting
* structure is placed in the specified object.
*
* Results:
- * A newly constructed ByteCode object is stored in the internal
+ * A newly-constructed ByteCode object is stored in the internal
* representation of the objPtr.
*
* Side effects:
@@ -2745,11 +2782,40 @@ TclCompileNoOp(
*----------------------------------------------------------------------
*/
-void
-TclInitByteCodeObj(
- Tcl_Obj *objPtr, /* Points object that should be initialized,
- * and whose string rep contains the source
- * code. */
+static void
+PreventCycle(
+ Tcl_Obj *objPtr,
+ CompileEnv *envPtr)
+{
+ int i;
+
+ for (i = 0; i < envPtr->literalArrayNext; i++) {
+ if (objPtr == TclFetchLiteral(envPtr, i)) {
+ /*
+ * Prevent circular reference where the bytecode internalrep of
+ * a value contains a literal which is that same value.
+ * If this is allowed to happen, refcount decrements may not
+ * reach zero, and memory may leak. Bugs 467523, 3357771
+ *
+ * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
+ * on the string value, and do not call Tcl_DuplicateObj() so we
+ * can be sure we do not have any lingering cycles hiding in
+ * the internalrep.
+ */
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
+ Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
+
+ Tcl_IncrRefCount(copyPtr);
+ TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);
+
+ envPtr->literalArrayPtr[i].objPtr = copyPtr;
+ }
+ }
+}
+
+ByteCode *
+TclInitByteCode(
CompileEnv *envPtr)/* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
@@ -2779,9 +2845,13 @@ TclInitByteCodeObj(
/*
* Compute the total number of bytes needed for this bytecode.
+ *
+ * Note that code bytes need not be aligned but since later elements are we
+ * need to pad anyway, either directly after ByteCode or after codeBytes,
+ * and it's easier and more consistent to do the former.
*/
- structureSize = sizeof(ByteCode);
+ structureSize = TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */
structureSize += TCL_ALIGN(codeBytes); /* align object array */
structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
@@ -2794,13 +2864,14 @@ TclInitByteCodeObj(
namespacePtr = envPtr->iPtr->globalNsPtr;
}
- p = ckalloc(structureSize);
+ p = (unsigned char *)ckalloc(structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
- codePtr->refCount = 1;
+ codePtr->refCount = 0;
+ TclPreserveByteCode(codePtr);
if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
} else {
@@ -2819,36 +2890,14 @@ TclInitByteCodeObj(
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
- p += sizeof(ByteCode);
+ p += TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */
codePtr->codeStart = p;
memcpy(p, envPtr->codeStart, codeBytes);
p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
- Tcl_Obj *fetched = TclFetchLiteral(envPtr, i);
-
- if (objPtr == fetched) {
- /*
- * Prevent circular reference where the bytecode internalrep of
- * a value contains a literal which is that same value.
- * If this is allowed to happen, refcount decrements may not
- * reach zero, and memory may leak. Bugs 467523, 3357771
- *
- * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
- * on the string value, and do not call Tcl_DuplicateObj() so we
- * can be sure we do not have any lingering cycles hiding in
- * the internalrep.
- */
- int numBytes;
- const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
-
- codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
- Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
- TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr);
- } else {
- codePtr->objArrayPtr[i] = fetched;
- }
+ codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i);
}
p += TCL_ALIGN(objArrayBytes); /* align exception range array */
@@ -2891,15 +2940,6 @@ TclInitByteCodeObj(
#endif /* TCL_COMPILE_STATS */
/*
- * Free the old internal rep then convert the object to a bytecode object
- * by making its internal rep point to the just compiled ByteCode.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->typePtr = &tclByteCodeType;
-
- /*
* TIP #280. Associate the extended per-word line information with the
* byte code object (internal rep), for use with the bc compiler.
*/
@@ -2912,6 +2952,31 @@ TclInitByteCodeObj(
envPtr->iPtr = NULL;
codePtr->localCachePtr = NULL;
+ return codePtr;
+}
+
+ByteCode *
+TclInitByteCodeObj(
+ Tcl_Obj *objPtr, /* Points object that should be initialized,
+ * and whose string rep contains the source
+ * code. */
+ const Tcl_ObjType *typePtr,
+ CompileEnv *envPtr)/* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
+{
+ ByteCode *codePtr;
+
+ PreventCycle(objPtr, envPtr);
+
+ codePtr = TclInitByteCode(envPtr);
+
+ /*
+ * Free the old internal rep then convert the object to a bytecode object
+ * by making its internal rep point to the just compiled ByteCode.
+ */
+
+ ByteCodeSetInternalRep(objPtr, typePtr, codePtr);
+ return codePtr;
}
/*
@@ -2950,7 +3015,7 @@ TclFindCompiledLocal(
CompileEnv *envPtr) /* Points to the current compile environment*/
{
CompiledLocal *localPtr;
- int localVar = -1;
+ int localVar = TCL_INDEX_NONE;
int i;
Proc *procPtr;
@@ -2973,19 +3038,19 @@ TclFindCompiledLocal(
int len;
if (!cachePtr || !name) {
- return -1;
+ return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = Tcl_GetStringFromObj(*varNamePtr, &len);
+ localName = TclGetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
- return -1;
+ return TCL_INDEX_NONE;
}
if (name != NULL) {
@@ -3011,7 +3076,7 @@ TclFindCompiledLocal(
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + 1U + nameBytes);
+ localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + 1U + nameBytes);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -3042,16 +3107,15 @@ TclFindCompiledLocal(
*
* TclExpandCodeArray --
*
- * Procedure that uses malloc to allocate more storage for a CompileEnv's
- * code array.
+ * Uses malloc to allocate more storage for a CompileEnv's code array.
*
* Results:
* None.
*
* Side effects:
- * The byte code array in *envPtr is reallocated to a new array of double
- * the size, and if envPtr->mallocedCodeArray is non-zero the old array
- * is freed. Byte codes are copied from the old array to the new one.
+ * The size of the bytecode array is doubled. If envPtr->mallocedCodeArray
+ * is non-zero the old array is freed. Byte codes are copied from the old
+ * array to the new one.
*
*----------------------------------------------------------------------
*/
@@ -3061,7 +3125,7 @@ TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
- CompileEnv *envPtr = envArgPtr;
+ CompileEnv *envPtr = (CompileEnv *)envArgPtr;
/* The CompileEnv containing the code array to
* be doubled in size. */
@@ -3075,14 +3139,14 @@ TclExpandCodeArray(
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
- envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes);
+ envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes);
} else {
/*
- * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
- * ckrealloc equivalent for ourselves.
+ * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so
+ * perform the equivalent of Tcl_Realloc directly.
*/
- unsigned char *newPtr = ckalloc(newBytes);
+ unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
@@ -3142,14 +3206,14 @@ EnterCmdStartData(
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
- envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes);
+ envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
* envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
- CmdLocation *newPtr = ckalloc(newBytes);
+ CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes);
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
@@ -3167,8 +3231,8 @@ EnterCmdStartData(
cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
- cmdLocPtr->numSrcBytes = -1;
- cmdLocPtr->numCodeBytes = -1;
+ cmdLocPtr->numSrcBytes = TCL_INDEX_NONE;
+ cmdLocPtr->numCodeBytes = TCL_INDEX_NONE;
}
/*
@@ -3246,7 +3310,6 @@ EnterCmdWordData(
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
- int len,
int numWords,
int line,
int *clNext,
@@ -3255,7 +3318,8 @@ EnterCmdWordData(
{
ECL *ePtr;
const char *last;
- int wordIdx, wordLine, *wwlines, *wordNext;
+ int wordIdx, wordLine;
+ int *wwlines, *wordNext;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
@@ -3268,16 +3332,16 @@ EnterCmdWordData(
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
- eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
+ eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
- ePtr->line = ckalloc(numWords * sizeof(int));
- ePtr->next = ckalloc(numWords * sizeof(int *));
+ ePtr->line = (int *)ckalloc(numWords * sizeof(int));
+ ePtr->next = (int **)ckalloc(numWords * sizeof(int *));
ePtr->nline = numWords;
- wwlines = ckalloc(numWords * sizeof(int));
+ wwlines = (int *)ckalloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
@@ -3290,7 +3354,7 @@ EnterCmdWordData(
/* See Ticket 4b61afd660 */
wwlines[wordIdx] =
((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL))
- ? wordLine : -1;
+ ? wordLine : TCL_INDEX_NONE;
ePtr->line[wordIdx] = wordLine;
ePtr->next[wordIdx] = wordNext;
last = tokenPtr->start;
@@ -3340,23 +3404,23 @@ TclCreateExceptRange(
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
- int newElems = 2*envPtr->exceptArrayEnd;
+ size_t newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
- ckrealloc(envPtr->exceptArrayPtr, newBytes);
+ (ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
- ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
+ (ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- ExceptionRange *newPtr = ckalloc(newBytes);
- ExceptionAux *newPtr2 = ckalloc(newBytes2);
+ ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes);
+ ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
@@ -3371,16 +3435,16 @@ TclCreateExceptRange(
rangePtr = &envPtr->exceptArrayPtr[index];
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
- rangePtr->codeOffset = -1;
- rangePtr->numCodeBytes = -1;
- rangePtr->breakOffset = -1;
- rangePtr->continueOffset = -1;
- rangePtr->catchOffset = -1;
+ rangePtr->codeOffset = TCL_INDEX_NONE;
+ rangePtr->numCodeBytes = TCL_INDEX_NONE;
+ rangePtr->breakOffset = TCL_INDEX_NONE;
+ rangePtr->continueOffset = TCL_INDEX_NONE;
+ rangePtr->catchOffset = TCL_INDEX_NONE;
auxPtr = &envPtr->exceptAuxArrayPtr[index];
auxPtr->supportsContinue = 1;
auxPtr->stackDepth = envPtr->currStackDepth;
auxPtr->expandTarget = envPtr->expandCount;
- auxPtr->expandTargetDepth = -1;
+ auxPtr->expandTargetDepth = TCL_INDEX_NONE;
auxPtr->numBreakTargets = 0;
auxPtr->breakTargets = NULL;
auxPtr->allocBreakTargets = 0;
@@ -3396,7 +3460,7 @@ TclCreateExceptRange(
* TclGetInnermostExceptionRange --
*
* Returns the innermost exception range that covers the current code
- * creation point, and (optionally) the stack depth that is expected at
+ * creation point, and optionally the stack depth that is expected at
* that point. Relies on the fact that the range has a numCodeBytes = -1
* when it is being populated and that inner ranges come after outer
* ranges.
@@ -3410,14 +3474,14 @@ TclGetInnermostExceptionRange(
int returnCode,
ExceptionAux **auxPtrPtr)
{
- int i = envPtr->exceptArrayNext;
+ size_t i = envPtr->exceptArrayNext;
ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i;
while (i > 0) {
rangePtr--; i--;
if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
- (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
+ (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) <
rangePtr->codeOffset+rangePtr->numCodeBytes) &&
(returnCode != TCL_CONTINUE ||
envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
@@ -3438,7 +3502,7 @@ TclGetInnermostExceptionRange(
*
* Adds a place that wants to break/continue to the loop exception range
* tracking that will be fixed up once the loop can be finalized. These
- * functions will generate an INST_JUMP4 that will be fixed up during the
+ * functions generate an INST_JUMP4 that is fixed up during the
* loop finalization.
*
* ---------------------------------------------------------------------
@@ -3459,11 +3523,11 @@ TclAddLoopBreakFixup(
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
- auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
+ auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets,
sizeof(int) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
- ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
+ (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
@@ -3485,11 +3549,11 @@ TclAddLoopContinueFixup(
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
- auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
+ auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets,
sizeof(int) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
- ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
+ (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
@@ -3502,8 +3566,8 @@ TclAddLoopContinueFixup(
*
* TclCleanupStackForBreakContinue --
*
- * Ditch the extra elements from the auxiliary stack and the main stack.
- * How to do this exactly depends on whether there are any elements on
+ * Removes the extra elements from the auxiliary stack and the main stack.
+ * How this is done depends on whether there are any elements on
* the auxiliary stack to pop.
*
* ---------------------------------------------------------------------
@@ -3514,7 +3578,7 @@ TclCleanupStackForBreakContinue(
CompileEnv *envPtr,
ExceptionAux *auxPtr)
{
- int savedStackDepth = envPtr->currStackDepth;
+ size_t savedStackDepth = envPtr->currStackDepth;
int toPop = envPtr->expandCount - auxPtr->expandTarget;
if (toPop > 0) {
@@ -3568,12 +3632,12 @@ StartExpanding(
if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
continue;
}
- if (rangePtr->numCodeBytes != -1) {
+ if (rangePtr->numCodeBytes != TCL_INDEX_NONE) {
continue;
}
/*
- * Adequate condition: further out loops and further in exceptions
+ * Adequate condition: loops further out and exceptions further in
* don't actually need this information.
*/
@@ -3583,7 +3647,7 @@ StartExpanding(
}
/*
- * There's now one more expansion being processed on the auxiliary stack.
+ * One more expansion is now being processed on the auxiliary stack.
*/
envPtr->expandCount++;
@@ -3596,7 +3660,7 @@ StartExpanding(
*
* Finalizes a loop exception range, binding the registered [break] and
* [continue] implementations so that they jump to the correct place.
- * Note that this must only be called after *all* the exception range
+ * This must be called only after *all* the exception range
* target offsets have been set.
*
* ---------------------------------------------------------------------
@@ -3628,7 +3692,7 @@ TclFinalizeLoopExceptionRange(
}
for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
site = envPtr->codeStart + auxPtr->continueTargets[i];
- if (rangePtr->continueOffset == -1) {
+ if (rangePtr->continueOffset == TCL_INDEX_NONE) {
int j;
/*
@@ -3667,27 +3731,23 @@ TclFinalizeLoopExceptionRange(
*
* TclCreateAuxData --
*
- * Procedure that allocates and initializes a new AuxData structure in a
+ * Allocates and initializes a new AuxData structure in a
* CompileEnv's array of compilation auxiliary data records. These
* AuxData records hold information created during compilation by
* CompileProcs and used by instructions during execution.
*
* Results:
- * Returns the index for the newly created AuxData structure.
+ * The index of the newly-created AuxData structure in the array.
*
* Side effects:
- * If there is not enough room in the CompileEnv's AuxData array, the
- * AuxData array in expanded: a new array of double the size is
- * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array
- * is freed, and AuxData entries are copied from the old array to the new
- * one.
- *
+ * If there is not enough room in the CompileEnv's AuxData array, its size
+ * is doubled.
*----------------------------------------------------------------------
*/
int
TclCreateAuxData(
- ClientData clientData, /* The compilation auxiliary data to store in
+ void *clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
@@ -3707,19 +3767,19 @@ TclCreateAuxData(
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
- int newElems = 2*envPtr->auxDataArrayEnd;
+ size_t newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
- ckrealloc(envPtr->auxDataArrayPtr, newBytes);
+ (AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- AuxData *newPtr = ckalloc(newBytes);
+ AuxData *newPtr = (AuxData *)ckalloc(newBytes);
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
@@ -3769,8 +3829,7 @@ TclInitJumpFixupArray(
*
* TclExpandJumpFixupArray --
*
- * Procedure that uses malloc to allocate more storage for a jump fixup
- * array.
+ * Uses malloc to allocate more storage for a jump fixup array.
*
* Results:
* None.
@@ -3797,18 +3856,18 @@ TclExpandJumpFixupArray(
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
- int newElems = 2*(fixupArrayPtr->end + 1);
+ size_t newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
- fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes);
+ fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
- JumpFixup *newPtr = ckalloc(newBytes);
+ JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes);
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
@@ -3849,10 +3908,11 @@ TclFreeJumpFixupArray(
*
* TclEmitForwardJump --
*
- * Procedure to emit a two-byte forward jump of kind "jumpType". Since
- * the jump may later have to be grown to five bytes if the jump target
- * is more than, say, 127 bytes away, this procedure also initializes a
- * JumpFixup record with information about the jump.
+ * Emits a two-byte forward jump of kind "jumpType". Also initializes a
+ * JumpFixup record with information about the jump. Since may later be
+ * necessary to increase the size of the jump instruction to five bytes if
+ * the jump target is more than, say, 127 bytes away.
+ *
*
* Results:
* None.
@@ -3907,16 +3967,17 @@ TclEmitForwardJump(
*
* TclFixupForwardJump --
*
- * Procedure that updates a previously-emitted forward jump to jump a
- * specified number of bytes, "jumpDist". If necessary, the jump is grown
- * from two to five bytes; this is done if the jump distance is greater
- * than "distThreshold" (normally 127 bytes). The jump is described by a
- * JumpFixup record previously initialized by TclEmitForwardJump.
+ * Modifies a previously-emitted forward jump to jump a specified number
+ * of bytes, "jumpDist". If necessary, the size of the jump instruction is
+ * increased from two to five bytes. This is done if the jump distance is
+ * greater than "distThreshold" (normally 127 bytes). The jump is
+ * described by a JumpFixup record previously initialized by
+ * TclEmitForwardJump.
*
* Results:
- * 1 if the jump was grown and subsequent instructions had to be moved;
- * otherwise 0. This result is returned to allow callers to update any
- * additional code offsets they may hold.
+ * 1 if the jump was grown and subsequent instructions had to be moved, or
+ * 0 otherwsie. This allows callers to update any additional code offsets
+ * they may hold.
*
* Side effects:
* The jump may be grown and subsequent instructions moved. If this
@@ -3940,7 +4001,7 @@ TclFixupForwardJump(
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
- unsigned numBytes;
+ size_t numBytes;
if (jumpDist <= distThreshold) {
jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
@@ -3959,10 +4020,10 @@ TclFixupForwardJump(
}
/*
- * We must grow the jump then move subsequent instructions down. Note that
- * if we expand the space for generated instructions, code addresses might
- * change; be careful about updating any of these addresses held in
- * variables.
+ * Increase the size of the jump instruction, and then move subsequent
+ * instructions down. Expanding the space for generated instructions means
+ * that code addresses might change. Be careful about updating any of
+ * these addresses held in variables.
*/
if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
@@ -4009,7 +4070,7 @@ TclFixupForwardJump(
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
- if (rangePtr->continueOffset != -1) {
+ if (rangePtr->continueOffset != TCL_INDEX_NONE) {
rangePtr->continueOffset += 3;
}
break;
@@ -4046,7 +4107,7 @@ TclFixupForwardJump(
*
* TclEmitInvoke --
*
- * Emit one of the invoke-related instructions, wrapping it if necessary
+ * Emits one of the invoke-related instructions, wrapping it if necessary
* in code that ensures that any break or continue operation passing
* through it gets the stack unwinding correct, converting it into an
* internal jump if in an appropriate context.
@@ -4056,7 +4117,7 @@ TclFixupForwardJump(
*
* Side effects:
* Issues the jump with all correct stack management. May create another
- * loop exception range; pointers to ExceptionRange and ExceptionAux
+ * loop exception range. Pointers to ExceptionRange and ExceptionAux
* structures should not be held across this call.
*
*----------------------------------------------------------------------
@@ -4114,12 +4175,11 @@ TclEmitInvoke(
va_end(argList);
/*
- * Determine if we need to handle break and continue exceptions with a
- * special handling exception range (so that we can correctly unwind the
- * stack).
+ * If the exceptions is for break or continue handle it with special
+ * handling exception range so the stack may be correctly unwound.
*
- * These must be done separately; they can be different (especially for
- * calls from inside a [for] increment clause).
+ * These must be done separately since they can be different, especially
+ * for calls from inside a [for] increment clause.
*/
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
@@ -4127,7 +4187,7 @@ TclEmitInvoke(
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxContinuePtr = NULL;
} else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
- && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
+ && (auxContinuePtr->expandTarget+expandCount == envPtr->expandCount)) {
auxContinuePtr = NULL;
} else {
continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr;
@@ -4137,8 +4197,8 @@ TclEmitInvoke(
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxBreakPtr = NULL;
} else if (auxContinuePtr == NULL
- && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
- && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
+ && auxBreakPtr->stackDepth+wordCount == envPtr->currStackDepth
+ && auxBreakPtr->expandTarget+expandCount == envPtr->expandCount) {
auxBreakPtr = NULL;
} else {
breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
@@ -4339,16 +4399,16 @@ GetCmdLocEncodingSize(
*
* EncodeCmdLocMap --
*
- * Encode the command location information for some compiled code into a
+ * Encodes the command location information for some compiled code into a
* ByteCode structure. The encoded command location map is stored as
- * three adjacent byte sequences.
+ * three-adjacent-byte sequences.
*
* Results:
- * Pointer to the first byte after the encoded command location
+ * A pointer to the first byte after the encoded command location
* information.
*
* Side effects:
- * The encoded information is stored into the block of memory headed by
+ * Stores encoded information into the block of memory headed by
* codePtr. Also records pointers to the start of the four byte sequences
* in fields in codePtr's ByteCode header structure.
*
@@ -4463,9 +4523,9 @@ EncodeCmdLocMap(
*
* RecordByteCodeStats --
*
- * Accumulates various compilation-related statistics for each newly
- * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
- * compiled with the -DTCL_COMPILE_STATS flag
+ * Accumulates compilation-related statistics for each newly-compiled
+ * ByteCode. Called by the TclInitByteCodeObj when Tcl is compiled with
+ * the -DTCL_COMPILE_STATS flag
*
* Results:
* None.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 997f08e..a5942de 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -87,22 +87,22 @@ typedef enum {
* to a catch PC offset. */
} ExceptionRangeType;
-typedef struct ExceptionRange {
+typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
- int nestingLevel; /* Static depth of the exception range. Used
+ Tcl_Size nestingLevel; /* Static depth of the exception range. Used
* to find the most deeply-nested range
* surrounding a PC at runtime. */
- int codeOffset; /* Offset of the first instruction byte of the
+ Tcl_Size codeOffset; /* Offset of the first instruction byte of the
* code range. */
- int numCodeBytes; /* Number of bytes in the code range. */
- int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
+ Tcl_Size numCodeBytes; /* Number of bytes in the code range. */
+ Tcl_Size breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
* offset for a break command in the range. */
- int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the
+ Tcl_Size continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the
* target PC offset for a continue command in
* the code range. Otherwise, ignore this
* range when processing a continue
* command. */
- int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
+ Tcl_Size catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
* offset for any "exception" in range. */
} ExceptionRange;
@@ -118,40 +118,40 @@ typedef struct ExceptionAux {
* one (see [for] next-clause) then we must
* not pick up the range when scanning for a
* target to continue to. */
- int stackDepth; /* The stack depth at the point where the
+ Tcl_Size stackDepth; /* The stack depth at the point where the
* exception range was created. This is used
* to calculate the number of POPs required to
* restore the stack to its prior state. */
- int expandTarget; /* The number of expansions expected on the
+ Tcl_Size expandTarget; /* The number of expansions expected on the
* auxData stack at the time the loop starts;
* we can't currently discard them except by
* doing INST_INVOKE_EXPANDED; this is a known
* problem. */
- int expandTargetDepth; /* The stack depth expected at the outermost
+ Tcl_Size expandTargetDepth; /* The stack depth expected at the outermost
* expansion within the loop. Not meaningful
* if there are no open expansions between the
* looping level and the point of jump
* issue. */
- int numBreakTargets; /* The number of [break]s that want to be
+ Tcl_Size numBreakTargets; /* The number of [break]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
- unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions
+ TCL_HASH_TYPE *breakTargets; /* The offsets of the INST_JUMP4 instructions
* issued by the [break]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numBreakTargets==0, this is NULL. */
- int allocBreakTargets; /* The size of the breakTargets array. */
- int numContinueTargets; /* The number of [continue]s that want to be
+ Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */
+ Tcl_Size numContinueTargets; /* The number of [continue]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
- unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions
+ TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions
* issued by the [continue]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numContinueTargets==0, this is NULL. */
- int allocContinueTargets; /* The size of the continueTargets array. */
+ Tcl_Size allocContinueTargets; /* The size of the continueTargets array. */
} ExceptionAux;
/*
@@ -162,11 +162,11 @@ typedef struct ExceptionAux {
* source offset is not monotonic.
*/
-typedef struct CmdLocation {
- int codeOffset; /* Offset of first byte of command code. */
- int numCodeBytes; /* Number of bytes for command's code. */
- int srcOffset; /* Offset of first char of the command. */
- int numSrcBytes; /* Number of command source chars. */
+typedef struct {
+ Tcl_Size codeOffset; /* Offset of first byte of command code. */
+ Tcl_Size numCodeBytes; /* Number of bytes for command's code. */
+ Tcl_Size srcOffset; /* Offset of first char of the command. */
+ Tcl_Size numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
@@ -180,9 +180,9 @@ typedef struct CmdLocation {
* frame and associated information, like the path of a sourced file.
*/
-typedef struct ECL {
- int srcOffset; /* Command location to find the entry. */
- int nline; /* Number of words in the command */
+typedef struct {
+ Tcl_Size srcOffset; /* Command location to find the entry. */
+ Tcl_Size 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
@@ -190,7 +190,7 @@ typedef struct ECL {
* lines. */
} ECL;
-typedef struct ExtCmdLoc {
+typedef struct {
int type; /* Context type. */
int start; /* Starting line for compiled script. Needed
* for the extended recompile check in
@@ -198,8 +198,8 @@ typedef struct ExtCmdLoc {
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_Size nloc; /* Number of allocated entries in 'loc'. */
+ Tcl_Size nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
@@ -217,11 +217,11 @@ typedef struct ExtCmdLoc {
* the AuxData structure.
*/
-typedef ClientData (AuxDataDupProc) (ClientData clientData);
-typedef void (AuxDataFreeProc) (ClientData clientData);
-typedef void (AuxDataPrintProc)(ClientData clientData,
+typedef void *(AuxDataDupProc) (void *clientData);
+typedef void (AuxDataFreeProc) (void *clientData);
+typedef void (AuxDataPrintProc)(void *clientData,
Tcl_Obj *appendObj, struct ByteCode *codePtr,
- unsigned int pcOffset);
+ TCL_HASH_TYPE pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
@@ -266,7 +266,7 @@ typedef struct AuxDataType {
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
- ClientData clientData; /* The compilation data itself. */
+ void *clientData; /* The compilation data itself. */
} AuxData;
/*
@@ -290,21 +290,21 @@ typedef struct CompileEnv {
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
- int numSrcBytes; /* Number of bytes in source. */
+ Tcl_Size numSrcBytes; /* Number of bytes in source. */
Proc *procPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise NULL. Used
* to compile local variables. Set from
* information provided by ObjInterpProc in
* tclProc.c. */
- int numCommands; /* Number of commands compiled. */
- int exceptDepth; /* Current exception range nesting level; -1
+ Tcl_Size numCommands; /* Number of commands compiled. */
+ Tcl_Size exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE
* if not in any range currently. */
- int maxExceptDepth; /* Max nesting level of exception ranges; -1
+ Tcl_Size maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE
* if no ranges have been compiled. */
- int maxStackDepth; /* Maximum number of stack elements needed to
+ Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. Set by compilation
* procedures before returning. */
- int currStackDepth; /* Current stack depth. */
+ Tcl_Size currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl
* objects referenced by this compiled code.
* Indexed by the string representations of
@@ -318,18 +318,18 @@ typedef struct CompileEnv {
* codeStart points into the heap.*/
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
- int literalArrayNext; /* Index of next free object array entry. */
- int literalArrayEnd; /* Index just after last obj array entry. */
+ Tcl_Size literalArrayNext; /* Index of next free object array entry. */
+ Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */
int mallocedLiteralArray; /* 1 if object array was expanded and objArray
* points into the heap, else 0. */
ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
- int exceptArrayNext; /* Next free ExceptionRange array index.
+ Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index.
* exceptArrayNext is the number of ranges and
* (exceptArrayNext-1) is the index of the
* current range's array entry. */
- int exceptArrayEnd; /* Index after the last ExceptionRange array
+ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
@@ -342,15 +342,15 @@ typedef struct CompileEnv {
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
* for the last command. */
- int cmdMapEnd; /* Index after last CmdLocation entry. */
+ Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
- int auxDataArrayNext; /* Next free compile aux data array index.
+ Tcl_Size auxDataArrayNext; /* Next free compile aux data array index.
* auxDataArrayNext is the number of aux data
* items and (auxDataArrayNext-1) is index of
* current aux data array entry. */
- int auxDataArrayEnd; /* Index after last aux data array entry. */
+ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
@@ -369,7 +369,7 @@ typedef struct CompileEnv {
/* TIP #280 */
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
* 'info frame'. */
- int line; /* First line of the script, based on the
+ Tcl_Size line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
int atCmdStart; /* Flag to say whether an INST_START_CMD
@@ -378,7 +378,7 @@ typedef struct CompileEnv {
* inefficient. If set to 2, that instruction
* should not be issued at all (by the generic
* part of the command compiler). */
- int expandCount; /* Number of INST_EXPAND_START instructions
+ Tcl_Size expandCount; /* Number of INST_EXPAND_START instructions
* encountered that have not yet been paired
* with a corresponding
* INST_INVOKE_EXPANDED. */
@@ -417,7 +417,7 @@ typedef struct ByteCode {
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
- int compileEpoch; /* Value of iPtr->compileEpoch when this
+ Tcl_Size compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
@@ -425,11 +425,11 @@ typedef struct ByteCode {
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
- int nsEpoch; /* Value of nsPtr->resolverEpoch when this
+ Tcl_Size nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
- int refCount; /* Reference count: set 1 when created plus 1
+ Tcl_Size refCount; /* Reference count: set 1 when created plus 1
* for each execution of the code currently
* active. This structure can be freed when
* refCount becomes zero. */
@@ -449,17 +449,17 @@ typedef struct ByteCode {
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
- int numCommands; /* Number of commands compiled. */
- int numSrcBytes; /* Number of source bytes compiled. */
- int numCodeBytes; /* Number of code bytes. */
- int numLitObjects; /* Number of objects in literal array. */
- int numExceptRanges; /* Number of ExceptionRange array elems. */
- int numAuxDataItems; /* Number of AuxData items. */
- int numCmdLocBytes; /* Number of bytes needed for encoded command
+ Tcl_Size numCommands; /* Number of commands compiled. */
+ Tcl_Size numSrcBytes; /* Number of source bytes compiled. */
+ Tcl_Size numCodeBytes; /* Number of code bytes. */
+ Tcl_Size numLitObjects; /* Number of objects in literal array. */
+ Tcl_Size numExceptRanges; /* Number of ExceptionRange array elems. */
+ Tcl_Size numAuxDataItems; /* Number of AuxData items. */
+ Tcl_Size numCmdLocBytes; /* Number of bytes needed for encoded command
* location information. */
- int maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
- * -1 if no ranges were compiled. */
- int maxStackDepth; /* Maximum number of stack elements needed to
+ Tcl_Size maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
+ * TCL_INDEX_NONE if no ranges were compiled. */
+ Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. */
unsigned char *codeStart; /* Points to the first byte of the code. This
* is just after the final ByteCode member
@@ -514,12 +514,29 @@ typedef struct ByteCode {
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
+
+#define ByteCodeSetInternalRep(objPtr, typePtr, codePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (codePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), (typePtr), &ir); \
+ } while (0)
+
+
+
+#define ByteCodeGetInternalRep(objPtr, typePtr, codePtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), (typePtr)); \
+ (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
- * INST_LOR) must match the entries in the array operatorStrings in
+ * INST_BITOR) must match the entries in the array operatorStrings in
* tclExecute.c.
*/
@@ -823,8 +840,18 @@ typedef struct ByteCode {
#define INST_CLOCK_READ 189
+#define INST_DICT_GET_DEF 190
+
+/* TIP 461 */
+#define INST_STR_LT 191
+#define INST_STR_GT 192
+#define INST_STR_LE 193
+#define INST_STR_GE 194
+
+#define INST_LREPLACE4 195
+
/* The last opcode */
-#define LAST_INST_OPCODE 189
+#define LAST_INST_OPCODE 195
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -862,7 +889,7 @@ typedef enum InstOperandType {
typedef struct InstructionDesc {
const char *name; /* Name of instruction. */
- int numBytes; /* Total number of bytes for instruction. */
+ Tcl_Size numBytes; /* Total number of bytes for instruction. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
* computations. The value INT_MIN signals
@@ -897,12 +924,13 @@ typedef enum InstStringClassType {
STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
- STR_CLASS_XDIGIT /* Characters that can be used as digits in
+ STR_CLASS_XDIGIT, /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
+ STR_CLASS_UNICODE /* Unicode characters. */
} InstStringClassType;
typedef struct StringClassDesc {
- const char *name; /* Name of the class. */
+ char name[8]; /* Name of the class. */
int (*comparator)(int); /* Function to test if a single unicode
* character is a member of the class. */
} StringClassDesc;
@@ -949,8 +977,8 @@ typedef struct JumpFixup {
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
- int next; /* Index of next free array entry. */
- int end; /* Index of last usable entry in array. */
+ Tcl_Size next; /* Index of next free array entry. */
+ Tcl_Size end; /* Index of last usable entry in array. */
int mallocedArray; /* 1 if array was expanded and fixups points
* into the heap, else 0. */
JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
@@ -965,8 +993,8 @@ typedef struct JumpFixupArray {
*/
typedef struct ForeachVarList {
- int numVars; /* The number of variables in the list. */
- int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers")
+ Tcl_Size numVars; /* The number of variables in the list. */
+ Tcl_Size varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers")
* for each variable in the procedure's array
* of local variables. Only scalar variables
* are supported. The actual size of this
@@ -982,11 +1010,11 @@ typedef struct ForeachVarList {
*/
typedef struct ForeachInfo {
- int numLists; /* The number of both the variable and value
+ Tcl_Size numLists; /* The number of both the variable and value
* lists of the foreach command. */
- int firstValueTemp; /* Index of the first temp var in a proc frame
+ Tcl_Size firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
- int loopCtTemp; /* Index of temp var in a proc frame holding
+ Tcl_Size loopCtTemp; /* Index of temp var in a proc frame holding
* the loop's iteration count. Used to
* determine next value list element to assign
* each loop var. */
@@ -1020,8 +1048,8 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType;
*/
typedef struct {
- int length; /* Size of array */
- int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when
+ Tcl_Size length; /* Size of array */
+ Tcl_Size varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when
* processing the start and end of a [dict
* update]. There is really more than one
* entry, and the structure is allocated to
@@ -1069,7 +1097,6 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
CompileEnv *envPtr);
-MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
@@ -1093,13 +1120,13 @@ MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp,
Tcl_Token *tokenPtr, CompileEnv *envPtr);
-MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
+MODULE_SCOPE int TclCreateAuxData(void *clientData,
const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
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,
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
+ int length, TCL_HASH_TYPE hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
@@ -1113,7 +1140,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
-MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
+MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
@@ -1123,8 +1150,9 @@ MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr,
int before, int after, int *indexPtr);
-MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
- CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
int numBytes, const CmdFrame *invoker, int word);
@@ -1161,40 +1189,15 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr);
-
-static inline void
-TclPreserveByteCode(
- ByteCode *codePtr)
-{
- codePtr->refCount++;
-}
-
-static inline void
-TclReleaseByteCode(
- ByteCode *codePtr)
-{
- if (codePtr->refCount-- > 1) {
- return;
- }
- /* Just dropped to refcount==0. Clean up. */
- TclCleanupByteCode(codePtr);
-}
-
+MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr);
+MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
const char *name, Namespace *nsPtr);
-MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclSingleOpCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclSortingOpCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclVariadicOpCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNoIdentOpCmd;
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr);
@@ -1208,10 +1211,9 @@ MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
-MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
+MODULE_SCOPE int TclPushProcCallFrame(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int isLambda);
-
/*
*----------------------------------------------------------------
@@ -1223,7 +1225,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
/*
* Simplified form to access AuxData.
*
- * ClientData TclFetchAuxData(CompileEng *envPtr, int index);
+ * void *TclFetchAuxData(CompileEng *envPtr, int index);
*/
#define TclFetchAuxData(envPtr, index) \
@@ -1234,29 +1236,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_UNSHARED 0x04
/*
- * 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)
-
-/*
- * 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 TclRegisterNewCmdLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
-
-/*
* Macro used to manually adjust the stack requirements; used in cases where
* the stack effect cannot be computed from the opcode and its operands, but
* is still known at compile time.
@@ -1282,10 +1261,10 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define TclCheckStackDepth(depth, envPtr) \
do { \
- int _dd = (depth); \
- if (_dd != (envPtr)->currStackDepth) { \
- Tcl_Panic("bad stack depth computations: is %i, should be %i", \
- (envPtr)->currStackDepth, _dd); \
+ size_t _dd = (depth); \
+ if (_dd != (size_t)(envPtr)->currStackDepth) { \
+ Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \
+ (size_t)(envPtr)->currStackDepth, _dd); \
} \
} while (0)
@@ -1527,7 +1506,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
(*((p)+3))))
/*
- * Macros used to compute the minimum and maximum of two integers. The ANSI C
+ * Macros used to compute the minimum and maximum of two values. The ANSI C
* "prototypes" for these macros are:
*
* int TclMin(int i, int j);
@@ -1571,9 +1550,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
*/
#define PushLiteral(envPtr, string, length) \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+ TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr))
#define PushStringLiteral(envPtr, string) \
- PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
+ PushLiteral((envPtr), (string), sizeof(string "") - 1)
/*
* Macro to advance to the next token; it is more mnemonic than the address
@@ -1589,7 +1568,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* 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);
+ * static ptrdiff_t CurrentOffset(CompileEnv *envPtr);
*/
#define CurrentOffset(envPtr) \
@@ -1602,9 +1581,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* of LOOP ranges is an interesting datum for debugging purposes, and that is
* what we compute now.
*
- * static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
- * static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
- * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
+ * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index);
+ * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index);
+ * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL);
*/
#define ExceptionRangeStarts(envPtr, index) \
@@ -1663,7 +1642,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
+ Tcl_Size eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
@@ -1705,6 +1684,12 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
/*
+ * Flags bits used by lreplace4 instruction
+ */
+#define TCL_LREPLACE4_END_IS_LAST 1 /* "end" refers to last element */
+#define TCL_LREPLACE4_SINGLE_INDEX 2 /* Second index absent (pure insert) */
+
+/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
@@ -1841,8 +1826,8 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi);
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { \
char n[35]; \
- sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \
- (unsigned long) getpid()); \
+ sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \
+ (size_t) getpid()); \
tclDTraceDebugLog = fopen(n, "a"); \
}
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 8ea1f4d..5bffbcb 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -4,7 +4,7 @@
* This file provides the facilities which allow Tcl and other packages
* to embed configuration information into their binary libraries.
*
- * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -41,11 +41,10 @@ typedef struct QCCD {
* Static functions in this file:
*/
-static Tcl_ObjCmdProc QueryConfigObjCmd;
-static void QueryConfigDelete(ClientData clientData);
+static Tcl_ObjCmdProc QueryConfigObjCmd;
+static Tcl_CmdDeleteProc QueryConfigDelete;
+static Tcl_InterpDeleteProc ConfigDictDeleteProc;
static Tcl_Obj * GetConfigDict(Tcl_Interp *interp);
-static void ConfigDictDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -77,11 +76,11 @@ Tcl_RegisterConfig(
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
- QCCD *cdPtr = ckalloc(sizeof(QCCD));
+ QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
- cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
+ cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
@@ -179,7 +178,7 @@ Tcl_RegisterConfig(
* QueryConfigObjCmd --
*
* Implementation of "::<package>::pkgconfig", the command to query
- * configuration information embedded into a binary library.
+ * configuration information embedded into a library.
*
* Results:
* A standard tcl result.
@@ -197,7 +196,7 @@ QueryConfigObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- QCCD *cdPtr = clientData;
+ QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
@@ -230,7 +229,7 @@ QueryConfigObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
- Tcl_GetString(pkgName), NULL);
+ TclGetString(pkgName), NULL);
return TCL_ERROR;
}
@@ -245,7 +244,7 @@ QueryConfigObjCmd(
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
- Tcl_GetString(objv[2]), NULL);
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -324,16 +323,16 @@ static void
QueryConfigDelete(
ClientData clientData)
{
- QCCD *cdPtr = clientData;
+ QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
- ckfree((char *)cdPtr->encoding);
+ ckfree(cdPtr->encoding);
}
- ckfree((char *)cdPtr);
+ ckfree(cdPtr);
}
/*
@@ -357,7 +356,7 @@ static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
- Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
+ Tcl_Obj *pDB = (Tcl_Obj *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
@@ -390,11 +389,9 @@ GetConfigDict(
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ TCL_UNUSED(Tcl_Interp *))
{
- Tcl_Obj *pDB = clientData;
-
- Tcl_DecrRefCount(pDB);
+ Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
diff --git a/generic/tclDate.c b/generic/tclDate.c
index 192c7b3..edf069a 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -352,7 +352,6 @@ typedef short yytype_int16;
# elif defined size_t
# define YYSIZE_T size_t
# elif ! defined YYSIZE_T
-# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# define YYSIZE_T size_t
# else
# define YYSIZE_T unsigned
@@ -2744,7 +2743,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
@@ -2754,7 +2753,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 6723069..77517e8 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -12,6 +12,12 @@
#ifndef _TCLDECLS
#define _TCLDECLS
+#include <stddef.h> /* for size_t */
+
+#ifdef TCL_NO_DEPRECATED
+# define Tcl_SavedResult void
+#endif /* TCL_NO_DEPRECATED */
+
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
@@ -23,6 +29,15 @@
# endif
#endif
+#if !defined(BUILD_tcl)
+# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg)
+#elif defined(TCL_NO_DEPRECATED)
+# define TCL_DEPRECATED(msg) MODULE_SCOPE
+#else
+# define TCL_DEPRECATED(msg) EXTERN
+#endif
+
+
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -44,34 +59,34 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp,
const char *name, const char *version,
const void *clientData);
/* 1 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 2 */
EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
/* 3 */
-EXTERN char * Tcl_Alloc(unsigned int size);
+EXTERN char * Tcl_Alloc(TCL_HASH_TYPE size);
/* 4 */
EXTERN void Tcl_Free(char *ptr);
/* 5 */
-EXTERN char * Tcl_Realloc(char *ptr, unsigned int size);
+EXTERN char * Tcl_Realloc(char *ptr, TCL_HASH_TYPE size);
/* 6 */
-EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file,
+EXTERN char * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file,
int line);
/* 7 */
EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line);
/* 8 */
-EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size,
+EXTERN char * Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line);
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
- Tcl_FileProc *proc, ClientData clientData);
+ Tcl_FileProc *proc, void *clientData);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
- Tcl_FileProc *proc, ClientData clientData);
+ Tcl_FileProc *proc, void *clientData);
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
@@ -94,9 +109,9 @@ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp,
EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...);
/* 16 */
EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes,
- int length);
+ Tcl_Size length);
/* 17 */
-EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]);
+EXTERN Tcl_Obj * Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[]);
/* 18 */
EXTERN int Tcl_ConvertToType(Tcl_Interp *interp,
Tcl_Obj *objPtr, const Tcl_ObjType *typePtr);
@@ -110,25 +125,28 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
/* 22 */
-EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file,
int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
- int length, const char *file, int line);
+ Tcl_Size numBytes, const char *file,
+ int line);
/* 24 */
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
const char *file, int line);
/* 25 */
-EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
+EXTERN Tcl_Obj * Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line);
/* 26 */
-EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
int line);
/* 27 */
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);
+EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes,
+ Tcl_Size length, const char *file, int line);
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr);
/* 30 */
@@ -141,7 +159,7 @@ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *intPtr);
/* 33 */
EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
- int *lengthPtr);
+ int *numBytesPtr);
/* 34 */
EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
double *doublePtr);
@@ -149,9 +167,9 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
-EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GetIndexFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
@@ -180,58 +198,69 @@ EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp,
Tcl_Obj ***objvPtr);
/* 46 */
EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp,
- Tcl_Obj *listPtr, int index,
+ Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr);
/* 47 */
EXTERN int Tcl_ListObjLength(Tcl_Interp *interp,
Tcl_Obj *listPtr, int *lengthPtr);
/* 48 */
EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
- Tcl_Obj *listPtr, int first, int count,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Obj *listPtr, Tcl_Size first,
+ Tcl_Size count, Tcl_Size objc,
+ Tcl_Obj *const objv[]);
/* 49 */
-EXTERN Tcl_Obj * Tcl_NewBooleanObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewBooleanObj(int intValue);
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
- int length);
+ Tcl_Size numBytes);
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue);
/* 52 */
-EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewIntObj(int intValue);
/* 53 */
-EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
+EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]);
/* 54 */
-EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewLongObj(long longValue);
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj(void);
/* 56 */
-EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length);
+EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length);
/* 57 */
-EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue);
/* 58 */
-EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes);
+EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr,
+ Tcl_Size numBytes);
/* 59 */
EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
- const unsigned char *bytes, int numBytes);
+ const unsigned char *bytes,
+ Tcl_Size numBytes);
/* 60 */
EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
/* 61 */
-EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
/* 62 */
-EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
+EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 63 */
-EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
/* 64 */
-EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
+EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length);
/* 65 */
EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
- int length);
+ Tcl_Size length);
/* 66 */
-EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddErrorInfo(Tcl_Interp *interp,
const char *message);
/* 67 */
-EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
const char *message, int length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
@@ -242,7 +271,7 @@ EXTERN void Tcl_AppendElement(Tcl_Interp *interp,
EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...);
/* 71 */
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
- ClientData clientData);
+ void *clientData);
/* 72 */
EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async);
/* 73 */
@@ -252,95 +281,96 @@ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async);
/* 75 */
EXTERN int Tcl_AsyncReady(void);
/* 76 */
-EXTERN void Tcl_BackgroundError(Tcl_Interp *interp);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_BackgroundError(Tcl_Interp *interp);
/* 77 */
-EXTERN char Tcl_Backslash(const char *src, int *readPtr);
+TCL_DEPRECATED("Use Tcl_UtfBackslash")
+char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
const char *optionName,
const char *optionList);
/* 79 */
EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp,
- Tcl_InterpDeleteProc *proc,
- ClientData clientData);
+ Tcl_InterpDeleteProc *proc, void *clientData);
/* 80 */
EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc,
- ClientData clientData);
+ void *clientData);
/* 81 */
EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan);
/* 82 */
EXTERN int Tcl_CommandComplete(const char *cmd);
/* 83 */
-EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Concat(Tcl_Size argc, const char *const *argv);
/* 84 */
-EXTERN int Tcl_ConvertElement(const char *src, char *dst,
+EXTERN Tcl_Size Tcl_ConvertElement(const char *src, char *dst,
int flags);
/* 85 */
-EXTERN int Tcl_ConvertCountedElement(const char *src,
- int length, char *dst, int flags);
+EXTERN Tcl_Size Tcl_ConvertCountedElement(const char *src,
+ Tcl_Size length, char *dst, int flags);
/* 86 */
EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp,
const char *childCmd, Tcl_Interp *target,
- const char *targetCmd, int argc,
- CONST84 char *const *argv);
+ const char *targetCmd, Tcl_Size argc,
+ const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp,
const char *childCmd, Tcl_Interp *target,
- const char *targetCmd, int objc,
+ const char *targetCmd, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 88 */
EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
- const char *chanName,
- ClientData instanceData, int mask);
+ const char *chanName, void *instanceData,
+ int mask);
/* 89 */
EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
- Tcl_ChannelProc *proc, ClientData clientData);
+ Tcl_ChannelProc *proc, void *clientData);
/* 90 */
EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan,
- Tcl_CloseProc *proc, ClientData clientData);
+ Tcl_CloseProc *proc, void *clientData);
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdProc *proc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 92 */
EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
- ClientData clientData);
+ void *clientData);
/* 93 */
EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
/* 95 */
-EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+void Tcl_CreateMathFunc(Tcl_Interp *interp,
const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
- ClientData clientData);
+ void *clientData);
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 97 */
-EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
+EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe);
/* 98 */
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
- Tcl_TimerProc *proc, ClientData clientData);
+ Tcl_TimerProc *proc, void *clientData);
/* 99 */
-EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
- Tcl_CmdTraceProc *proc,
- ClientData clientData);
+EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level,
+ Tcl_CmdTraceProc *proc, void *clientData);
/* 100 */
EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp,
const char *name);
/* 101 */
EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan,
- Tcl_ChannelProc *proc, ClientData clientData);
+ Tcl_ChannelProc *proc, void *clientData);
/* 102 */
EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan,
- Tcl_CloseProc *proc, ClientData clientData);
+ Tcl_CloseProc *proc, void *clientData);
/* 103 */
EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp,
const char *cmdName);
@@ -349,14 +379,14 @@ EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp,
Tcl_Command command);
/* 105 */
EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc,
- ClientData clientData);
+ void *clientData);
/* 106 */
EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
- ClientData clientData);
+ void *clientData);
/* 107 */
EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 108 */
EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr);
/* 109 */
@@ -364,23 +394,21 @@ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr);
/* 110 */
EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp);
/* 111 */
-EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr);
+EXTERN void Tcl_DetachPids(Tcl_Size numPids, Tcl_Pid *pidPtr);
/* 112 */
EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token);
/* 113 */
EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace);
/* 114 */
EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
- Tcl_InterpDeleteProc *proc,
- ClientData clientData);
+ Tcl_InterpDeleteProc *proc, void *clientData);
/* 115 */
EXTERN int Tcl_DoOneEvent(int flags);
/* 116 */
-EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc,
- ClientData clientData);
+EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData);
/* 117 */
EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr,
- const char *bytes, int length);
+ const char *bytes, Tcl_Size length);
/* 118 */
EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr,
const char *element);
@@ -397,24 +425,26 @@ EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr);
EXTERN void Tcl_DStringResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
/* 124 */
-EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length);
+EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr,
+ Tcl_Size length);
/* 125 */
EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
/* 127 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoId(void);
+EXTERN const char * Tcl_ErrnoId(void);
/* 128 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err);
+EXTERN const char * Tcl_ErrnoMsg(int err);
/* 129 */
EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
EXTERN int Tcl_EvalFile(Tcl_Interp *interp,
const char *fileName);
/* 131 */
-EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/* 132 */
-EXTERN void Tcl_EventuallyFree(ClientData clientData,
+EXTERN void Tcl_EventuallyFree(void *clientData,
Tcl_FreeProc *freeProc);
/* 133 */
EXTERN TCL_NORETURN void Tcl_Exit(int status);
@@ -448,44 +478,45 @@ EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr);
/* 143 */
EXTERN void Tcl_Finalize(void);
/* 144 */
-EXTERN void Tcl_FindExecutable(const char *argv0);
+EXTERN const char * Tcl_FindExecutable(const char *argv0);
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr);
/* 146 */
EXTERN int Tcl_Flush(Tcl_Channel chan);
/* 147 */
-EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
+TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult")
+void Tcl_FreeResult(Tcl_Interp *interp);
/* 148 */
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char **targetCmdPtr, int *argcPtr,
+ const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *objcPtr,
+ const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
-EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
+EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp,
const char *name,
Tcl_InterpDeleteProc **procPtr);
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp,
const char *chanName, int *modePtr);
/* 152 */
-EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan);
+EXTERN Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan);
/* 153 */
EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
- ClientData *handlePtr);
+ void **handlePtr);
/* 154 */
-EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
+EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan);
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
/* 156 */
-EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan);
+EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan);
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -496,17 +527,17 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
-EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
+EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
/* 161 */
EXTERN int Tcl_GetErrno(void);
/* 162 */
-EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
+EXTERN const char * Tcl_GetHostName(void);
/* 163 */
EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp,
Tcl_Interp *childInterp);
/* 164 */
-EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp);
+EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp);
/* 165 */
EXTERN const char * Tcl_GetNameOfExecutable(void);
/* 166 */
@@ -515,40 +546,41 @@ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp);
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr);
+ int checkUsage, void **filePtr);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr);
+ int checkUsage, void **filePtr);
#endif /* MACOSX */
/* 168 */
EXTERN Tcl_PathType Tcl_GetPathType(const char *path);
/* 169 */
-EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
+EXTERN Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
/* 170 */
-EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 171 */
EXTERN int Tcl_GetServiceMode(void);
/* 172 */
-EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name);
+EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name);
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
-EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp);
+EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
-EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp,
- const char *varName, int flags);
-/* 176 */
-EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags);
+/* 176 */
+EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
/* 178 */
-EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GlobalEvalObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 179 */
EXTERN int Tcl_HideCommand(Tcl_Interp *interp,
@@ -568,20 +600,21 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp);
/* 185 */
EXTERN int Tcl_IsSafe(Tcl_Interp *interp);
/* 186 */
-EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv,
+EXTERN char * Tcl_JoinPath(Tcl_Size argc, const char *const *argv,
Tcl_DString *resultPtr);
/* 187 */
EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
- char *addr, int type);
+ void *addr, int type);
/* Slot 188 is reserved */
/* 189 */
-EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode);
+EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode);
/* 190 */
-EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
+TCL_DEPRECATED("")
+int Tcl_MakeSafe(Tcl_Interp *interp);
/* 191 */
-EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
+EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket);
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Merge(Tcl_Size argc, const char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
/* 194 */
@@ -594,8 +627,8 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
int flags);
/* 197 */
-EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags);
+EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp,
+ Tcl_Size argc, const char **argv, int flags);
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
const char *fileName, const char *modeString,
@@ -608,21 +641,21 @@ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host,
Tcl_TcpAcceptProc *acceptProc,
- ClientData callbackData);
+ void *callbackData);
/* 201 */
-EXTERN void Tcl_Preserve(ClientData data);
+EXTERN void Tcl_Preserve(void *data);
/* 202 */
EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
char *dst);
/* 203 */
EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
-EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp);
+EXTERN const char * Tcl_PosixError(Tcl_Interp *interp);
/* 205 */
-EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr,
- Tcl_QueuePosition position);
+EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position);
/* 206 */
-EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead);
+EXTERN Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr,
+ Tcl_Size toRead);
/* 207 */
EXTERN void Tcl_ReapDetachedProcs(void);
/* 208 */
@@ -646,20 +679,20 @@ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
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);
+EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index,
+ const char **startPtr, const char **endPtr);
/* 216 */
-EXTERN void Tcl_Release(ClientData clientData);
+EXTERN void Tcl_Release(void *clientData);
/* 217 */
EXTERN void Tcl_ResetResult(Tcl_Interp *interp);
/* 218 */
-EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
+EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr);
/* 219 */
-EXTERN int Tcl_ScanCountedElement(const char *src, int length,
- int *flagPtr);
+EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src,
+ Tcl_Size length, int *flagPtr);
/* 220 */
-EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
+TCL_DEPRECATED("")
+int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
/* 221 */
EXTERN int Tcl_ServiceAll(void);
/* 222 */
@@ -667,9 +700,10 @@ EXTERN int Tcl_ServiceEvent(int flags);
/* 223 */
EXTERN void Tcl_SetAssocData(Tcl_Interp *interp,
const char *name, Tcl_InterpDeleteProc *proc,
- ClientData clientData);
+ void *clientData);
/* 224 */
-EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz);
+EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan,
+ Tcl_Size sz);
/* 225 */
EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -685,10 +719,11 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...);
/* 229 */
EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr);
/* 230 */
-EXTERN void Tcl_SetPanicProc(
+EXTERN const char * Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
/* 231 */
-EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
+EXTERN Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp,
+ Tcl_Size depth);
/* 232 */
EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc);
@@ -703,50 +738,52 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
-EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp,
- const char *varName, const char *newValue,
- int flags);
-/* 238 */
-EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
+/* 238 */
+EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, const char *newValue,
+ int flags);
/* 239 */
-EXTERN CONST84_RETURN char * Tcl_SignalId(int sig);
+EXTERN const char * Tcl_SignalId(int sig);
/* 240 */
-EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig);
+EXTERN const char * Tcl_SignalMsg(int sig);
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 243 */
EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 244 */
-EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
+EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
- Tcl_PackageInitProc *initProc,
- Tcl_PackageInitProc *safeInitProc);
+ Tcl_LibraryInitProc *initProc,
+ Tcl_LibraryInitProc *safeInitProc);
/* 245 */
-EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
-EXTERN int Tcl_TellOld(Tcl_Channel chan);
+TCL_DEPRECATED("")
+int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
-EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
- ClientData clientData);
+ void *clientData);
/* 248 */
EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags,
- Tcl_VarTraceProc *proc,
- ClientData clientData);
+ Tcl_VarTraceProc *proc, void *clientData);
/* 249 */
EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp,
const char *name, Tcl_DString *bufferPtr);
/* 250 */
-EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str,
- int len, int atHead);
+EXTERN Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str,
+ Tcl_Size len, int atHead);
/* 251 */
EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
const char *varName);
@@ -754,26 +791,28 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
/* 253 */
-EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
int flags);
/* 254 */
EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 255 */
-EXTERN void Tcl_UntraceVar(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_UntraceVar(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_VarTraceProc *proc,
- ClientData clientData);
+ Tcl_VarTraceProc *proc, void *clientData);
/* 256 */
EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc,
- ClientData clientData);
+ void *clientData);
/* 257 */
EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp,
const char *varName);
/* 258 */
-EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName,
int flags);
/* 259 */
@@ -783,59 +822,67 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
/* 260 */
EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...);
/* 261 */
-EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void * Tcl_VarTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 262 */
-EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp,
+EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 263 */
-EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen);
+EXTERN Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s,
+ Tcl_Size slen);
/* 264 */
-EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
+EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message);
/* 265 */
EXTERN int Tcl_DumpActiveMemory(const char *fileName);
/* 266 */
EXTERN void Tcl_ValidateAllMemory(const char *file, int line);
/* 267 */
-EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
/* 268 */
-EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
-EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
- const char *start, CONST84 char **termPtr);
+EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr);
/* 271 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 272 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
-EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+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,
- int exact);
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 275 */
-EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
/* 276 */
-EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
/* 278 */
-EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
@@ -844,7 +891,7 @@ EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
/* 281 */
EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
const Tcl_ChannelType *typePtr,
- ClientData instanceData, int mask,
+ void *instanceData, int mask,
Tcl_Channel prevChan);
/* 282 */
EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp,
@@ -861,38 +908,39 @@ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr,
EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr);
/* 288 */
EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 289 */
EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 290 */
-EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
+TCL_DEPRECATED("Use Tcl_DiscardInterpState")
+void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
/* 291 */
EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script,
- int numBytes, int flags);
+ Tcl_Size numBytes, int flags);
/* 292 */
-EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
+EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags);
/* 293 */
EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
/* 294 */
-EXTERN void Tcl_ExitThread(int status);
+EXTERN TCL_NORETURN void Tcl_ExitThread(int status);
/* 295 */
EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
- int srcLen, int flags,
+ Tcl_Size srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr,
+ Tcl_Size dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 296 */
EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- const char *src, int srcLen,
+ const char *src, Tcl_Size srcLen,
Tcl_DString *dsPtr);
/* 297 */
EXTERN void Tcl_FinalizeThread(void);
/* 298 */
-EXTERN void Tcl_FinalizeNotifier(ClientData clientData);
+EXTERN void Tcl_FinalizeNotifier(void *clientData);
/* 299 */
EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding);
/* 300 */
@@ -900,22 +948,22 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
-EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding);
+EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp,
Tcl_Obj *objPtr, const void *tablePtr,
- int offset, const char *msg, int flags,
- int *indexPtr);
+ Tcl_Size offset, const char *msg, int flags,
+ void *indexPtr);
/* 305 */
EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
- int size);
+ Tcl_Size size);
/* 306 */
EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 307 */
-EXTERN ClientData Tcl_InitNotifier(void);
+EXTERN void * Tcl_InitNotifier(void);
/* 308 */
EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr);
/* 309 */
@@ -926,15 +974,17 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr);
EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr,
Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr);
/* 312 */
-EXTERN int Tcl_NumUtfChars(const char *src, int length);
+EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length);
/* 313 */
-EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
- int charsToRead, int appendFlag);
+EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
+ Tcl_Size charsToRead, int appendFlag);
/* 314 */
-EXTERN void Tcl_RestoreResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_RestoreInterpState")
+void Tcl_RestoreResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 315 */
-EXTERN void Tcl_SaveResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_SaveInterpState")
+void Tcl_SaveResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 316 */
EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp,
@@ -947,64 +997,67 @@ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
/* 319 */
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
- Tcl_Event *evPtr, Tcl_QueuePosition position);
+ Tcl_Event *evPtr, int position);
/* 320 */
-EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int Tcl_UniCharAtIndex(const char *src, Tcl_Size index);
/* 321 */
-EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch);
+EXTERN int Tcl_UniCharToLower(int ch);
/* 322 */
-EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch);
+EXTERN int Tcl_UniCharToTitle(int ch);
/* 323 */
-EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
+EXTERN int Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
+EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index);
/* 326 */
-EXTERN int Tcl_UtfCharComplete(const char *src, int length);
+EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length);
/* 327 */
-EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
+EXTERN Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
/* 328 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
-EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src);
+EXTERN const char * TclUtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
+EXTERN const char * TclUtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
- int srcLen, int flags,
+ Tcl_Size srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr,
+ Tcl_Size dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 333 */
EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- const char *src, int srcLen,
+ const char *src, Tcl_Size srcLen,
Tcl_DString *dsPtr);
/* 334 */
EXTERN int Tcl_UtfToLower(char *src);
/* 335 */
EXTERN int Tcl_UtfToTitle(char *src);
/* 336 */
-EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr);
+EXTERN int Tcl_UtfToChar16(const char *src,
+ unsigned short *chPtr);
/* 337 */
EXTERN int Tcl_UtfToUpper(char *src);
/* 338 */
-EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src,
- int srcLen);
+EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src,
+ Tcl_Size srcLen);
/* 339 */
-EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
/* 341 */
-EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void);
+TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath")
+const char * Tcl_GetDefaultEncodingDir(void);
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir(const char *path);
+TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath")
+void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
-EXTERN void Tcl_AlertNotifier(ClientData clientData);
+EXTERN void Tcl_AlertNotifier(void *clientData);
/* 344 */
EXTERN void Tcl_ServiceModeHook(int mode);
/* 345 */
@@ -1022,49 +1075,51 @@ EXTERN int Tcl_UniCharIsUpper(int ch);
/* 351 */
EXTERN int Tcl_UniCharIsWordChar(int ch);
/* 352 */
-EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
+EXTERN Tcl_Size Tcl_Char16Len(const unsigned short *uniStr);
/* 353 */
-EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
- const Tcl_UniChar *uct,
+TCL_DEPRECATED("Use Tcl_UtfNcmp")
+int Tcl_UniCharNcmp(const unsigned short *ucs,
+ const unsigned short *uct,
unsigned long numChars);
/* 354 */
-EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
- int uniLength, Tcl_DString *dsPtr);
+EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr);
/* 355 */
-EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
- Tcl_DString *dsPtr);
+EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr);
/* 356 */
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
/* 357 */
-EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_EvalTokensStandard")
+Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
/* 359 */
EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
const char *script, const char *command,
- int length);
+ Tcl_Size length);
/* 360 */
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
- const char *start, int numBytes, int nested,
- Tcl_Parse *parsePtr);
+ const char *start, Tcl_Size numBytes,
+ int nested, Tcl_Parse *parsePtr);
/* 362 */
EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr);
+ Tcl_Size numBytes, Tcl_Parse *parsePtr);
/* 363 */
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append);
/* 365 */
EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
@@ -1094,32 +1149,38 @@ EXTERN int Tcl_UniCharIsPunct(int ch);
/* 376 */
EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp,
Tcl_RegExp regexp, Tcl_Obj *textObj,
- int offset, int nmatches, int flags);
+ Tcl_Size offset, Tcl_Size nmatches,
+ int flags);
/* 377 */
EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp,
Tcl_RegExpInfo *infoPtr);
/* 378 */
-EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode,
- int numChars);
+EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode,
+ Tcl_Size numChars);
/* 379 */
EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const unsigned short *unicode,
+ Tcl_Size numChars);
/* 380 */
-EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
-EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index);
/* 382 */
-EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
-EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
+EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first,
+ Tcl_Size last);
/* 384 */
EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int length);
+ const unsigned short *unicode,
+ Tcl_Size length);
/* 385 */
EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp,
Tcl_Obj *textObj, Tcl_Obj *patternObj);
/* 386 */
-EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr);
+EXTERN void Tcl_SetNotifier(
+ const Tcl_NotifierProcs *notifierProcPtr);
/* 387 */
EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void);
/* 388 */
@@ -1128,31 +1189,28 @@ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp);
EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp,
const char *pattern);
/* 390 */
-EXTERN int Tcl_ProcObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 391 */
EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr);
/* 392 */
EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex);
/* 393 */
EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr,
- Tcl_ThreadCreateProc *proc,
- ClientData clientData, int stackSize,
- int flags);
+ Tcl_ThreadCreateProc *proc, void *clientData,
+ Tcl_Size stackSize, int flags);
/* 394 */
-EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst,
- int bytesToRead);
+EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst,
+ Tcl_Size bytesToRead);
/* 395 */
-EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src,
- int srcLen);
+EXTERN Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src,
+ Tcl_Size srcLen);
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
/* 398 */
-EXTERN CONST84_RETURN char * Tcl_ChannelName(
- const Tcl_ChannelType *chanTypePtr);
+EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
@@ -1160,7 +1218,8 @@ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr);
/* 401 */
-EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
+TCL_DEPRECATED("Use Tcl_ChannelClose2Proc")
+Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr);
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(
@@ -1172,7 +1231,8 @@ EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc(
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr);
/* 405 */
-EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
+TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc")
+Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr);
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(
@@ -1208,12 +1268,14 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel);
/* 418 */
EXTERN int Tcl_IsChannelExisting(const char *channelName);
/* 419 */
-EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
- const Tcl_UniChar *uct,
+TCL_DEPRECATED("Use Tcl_UtfNcasecmp")
+int Tcl_UniCharNcasecmp(const unsigned short *ucs,
+ const unsigned short *uct,
unsigned long numChars);
/* 420 */
-EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
- const Tcl_UniChar *uniPattern, int nocase);
+TCL_DEPRECATED("Use Tcl_StringCaseMatch")
+int Tcl_UniCharCaseMatch(const unsigned short *uniStr,
+ const unsigned short *uniPattern, int nocase);
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr,
const void *key);
@@ -1226,45 +1288,45 @@ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr,
/* 424 */
EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr);
/* 425 */
-EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp,
+EXTERN void * Tcl_CommandTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_CommandTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 426 */
EXTERN int Tcl_TraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_CommandTraceProc *proc,
- ClientData clientData);
+ Tcl_CommandTraceProc *proc, void *clientData);
/* 427 */
EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_CommandTraceProc *proc,
- ClientData clientData);
+ Tcl_CommandTraceProc *proc, void *clientData);
/* 428 */
-EXTERN char * Tcl_AttemptAlloc(unsigned int size);
+EXTERN char * Tcl_AttemptAlloc(TCL_HASH_TYPE size);
/* 429 */
-EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size,
+EXTERN char * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size,
const char *file, int line);
/* 430 */
-EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size);
+EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size);
/* 431 */
-EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
+EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line);
/* 432 */
-EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length);
+EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr,
+ Tcl_Size length);
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
/* 434 */
-EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
+EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 435 */
-EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
- Tcl_MathProc **procPtr,
- ClientData *clientDataPtr);
+ Tcl_MathProc **procPtr, void **clientDataPtr);
/* 436 */
-EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -1287,8 +1349,8 @@ EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr);
/* 444 */
EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *sym1, const char *sym2,
- Tcl_PackageInitProc **proc1Ptr,
- Tcl_PackageInitProc **proc2Ptr,
+ Tcl_LibraryInitProc **proc1Ptr,
+ Tcl_LibraryInitProc **proc2Ptr,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr);
/* 445 */
@@ -1333,7 +1395,7 @@ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr);
EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/* 460 */
-EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, int elements);
+EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements);
/* 461 */
EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
/* 462 */
@@ -1343,10 +1405,10 @@ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr,
EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/* 464 */
-EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
+EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 465 */
-EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
+EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr);
/* 466 */
EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp,
@@ -1356,7 +1418,7 @@ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName);
/* 468 */
EXTERN Tcl_Obj * Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
- ClientData clientData);
+ void *clientData);
/* 469 */
EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr);
/* 470 */
@@ -1366,12 +1428,12 @@ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr);
/* 472 */
EXTERN Tcl_Obj * Tcl_FSListVolumes(void);
/* 473 */
-EXTERN int Tcl_FSRegister(ClientData clientData,
+EXTERN int Tcl_FSRegister(void *clientData,
const Tcl_Filesystem *fsPtr);
/* 474 */
EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr);
/* 475 */
-EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr);
+EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr);
/* 476 */
EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
@@ -1385,13 +1447,14 @@ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan);
EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr);
/* 481 */
EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp,
- Tcl_Token *tokenPtr, int count);
+ Tcl_Token *tokenPtr, Tcl_Size count);
/* 482 */
EXTERN void Tcl_GetTime(Tcl_Time *timeBuf);
/* 483 */
-EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level,
- int flags, Tcl_CmdObjTraceProc *objProc,
- ClientData clientData,
+EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp,
+ Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc *objProc,
+ void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc);
/* 484 */
EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token,
@@ -1413,10 +1476,10 @@ EXTERN void Tcl_SetWideIntObj(Tcl_Obj *objPtr,
/* 490 */
EXTERN Tcl_StatBuf * Tcl_AllocStatBuf(void);
/* 491 */
-EXTERN Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset,
+EXTERN long long Tcl_Seek(Tcl_Channel chan, long long offset,
int mode);
/* 492 */
-EXTERN Tcl_WideInt Tcl_Tell(Tcl_Channel chan);
+EXTERN long long Tcl_Tell(Tcl_Channel chan);
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr);
@@ -1445,11 +1508,11 @@ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr,
EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr);
/* 501 */
EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp,
- Tcl_Obj *dictPtr, int keyc,
+ Tcl_Obj *dictPtr, Tcl_Size keyc,
Tcl_Obj *const *keyv, Tcl_Obj *valuePtr);
/* 502 */
EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp,
- Tcl_Obj *dictPtr, int keyc,
+ Tcl_Obj *dictPtr, Tcl_Size keyc,
Tcl_Obj *const *keyv);
/* 503 */
EXTERN Tcl_Obj * Tcl_NewDictObj(void);
@@ -1462,7 +1525,7 @@ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp,
const char *valEncoding);
/* 506 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- const char *name, ClientData clientData,
+ const char *name, void *clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 507 */
EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
@@ -1503,12 +1566,12 @@ EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc);
/* 520 */
EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData,
+ void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc);
/* 521 */
EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData);
+ void *clientData);
/* 522 */
EXTERN int Tcl_LimitReady(Tcl_Interp *interp);
/* 523 */
@@ -1517,7 +1580,7 @@ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp);
EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp);
/* 525 */
EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp,
- int commandLimit);
+ Tcl_Size commandLimit);
/* 526 */
EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp,
Tcl_Time *timeLimitPtr);
@@ -1591,30 +1654,30 @@ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp,
/* 552 */
EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
- ClientData clientData);
+ void *clientData);
/* 553 */
EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
- ClientData *clientData);
+ void **clientData);
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr);
/* 555 */
-EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value);
+EXTERN Tcl_Obj * Tcl_NewBignumObj(void *value);
/* 556 */
-EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, const char *file,
+EXTERN Tcl_Obj * Tcl_DbNewBignumObj(void *value, const char *file,
int line);
/* 557 */
-EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value);
+EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, void *value);
/* 558 */
EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp,
- Tcl_Obj *obj, mp_int *value);
+ Tcl_Obj *obj, void *value);
/* 559 */
EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp,
- Tcl_Obj *obj, mp_int *value);
+ Tcl_Obj *obj, void *value);
/* 560 */
EXTERN int Tcl_TruncateChannel(Tcl_Channel chan,
- Tcl_WideInt length);
+ long long length);
/* 561 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc(
const Tcl_ChannelType *chanTypePtr);
@@ -1630,7 +1693,7 @@ EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg);
EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg);
/* 566 */
EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp,
- double initval, mp_int *toInit);
+ double initval, void *toInit);
/* 567 */
EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr);
@@ -1649,22 +1712,22 @@ EXTERN const char * Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr);
/* 573 */
EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp,
- const char *name, int objc,
+ const char *name, Tcl_Size objc,
Tcl_Obj *const objv[], void *clientDataPtr);
/* 574 */
EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 575 */
EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr,
- const char *bytes, int length, int limit,
- const char *ellipsis);
+ const char *bytes, Tcl_Size length,
+ Tcl_Size limit, const char *ellipsis);
/* 576 */
EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size 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[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 578 */
EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
/* 579 */
@@ -1672,7 +1735,7 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr,
const char *format, ...) TCL_FORMAT_PRINTF(2, 3);
/* 580 */
EXTERN int Tcl_CancelEval(Tcl_Interp *interp,
- Tcl_Obj *resultObjPtr, ClientData clientData,
+ Tcl_Obj *resultObjPtr, void *clientData,
int flags);
/* 581 */
EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags);
@@ -1683,28 +1746,26 @@ EXTERN int Tcl_CreatePipe(Tcl_Interp *interp,
/* 583 */
EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
+ Tcl_ObjCmdProc *nreProc, void *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,
+EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size 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);
+ Tcl_Size 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);
+ Tcl_NRPostProc *postProcPtr, void *data0,
+ void *data1, void *data2, void *data3);
/* 588 */
EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp,
- Tcl_ObjCmdProc *objProc,
- ClientData clientData, int objc,
- Tcl_Obj *const objv[]);
+ Tcl_ObjCmdProc *objProc, void *clientData,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 589 */
EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr);
/* 590 */
@@ -1720,16 +1781,16 @@ 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);
+EXTERN long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr);
/* 597 */
-EXTERN Tcl_WideInt Tcl_GetModificationTimeFromStat(
+EXTERN long long Tcl_GetModificationTimeFromStat(
const Tcl_StatBuf *statPtr);
/* 598 */
-EXTERN Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr);
+EXTERN long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr);
/* 599 */
-EXTERN Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr);
+EXTERN unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr);
/* 600 */
-EXTERN Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr);
+EXTERN unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr);
/* 601 */
EXTERN unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr);
/* 602 */
@@ -1759,14 +1820,14 @@ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format,
Tcl_Obj *gzipHeaderDictObj);
/* 611 */
EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format,
- Tcl_Obj *data, int buffersize,
+ Tcl_Obj *data, Tcl_Size buffersize,
Tcl_Obj *gzipHeaderDictObj);
/* 612 */
EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc,
- const unsigned char *buf, int len);
+ const unsigned char *buf, Tcl_Size len);
/* 613 */
EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler,
- const unsigned char *buf, int len);
+ const unsigned char *buf, Tcl_Size len);
/* 614 */
EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode,
int format, int level, Tcl_Obj *dictObj,
@@ -1782,7 +1843,7 @@ 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);
+ Tcl_Obj *data, Tcl_Size count);
/* 620 */
EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle);
/* 621 */
@@ -1815,61 +1876,175 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
-/* Slot 631 is reserved */
-/* Slot 632 is reserved */
-/* Slot 633 is reserved */
-/* Slot 634 is reserved */
-/* Slot 635 is reserved */
-/* Slot 636 is reserved */
-/* Slot 637 is reserved */
-/* Slot 638 is reserved */
-/* Slot 639 is reserved */
-/* Slot 640 is reserved */
-/* Slot 641 is reserved */
-/* Slot 642 is reserved */
-/* Slot 643 is reserved */
-/* Slot 644 is reserved */
-/* Slot 645 is reserved */
-/* Slot 646 is reserved */
-/* Slot 647 is reserved */
-/* Slot 648 is reserved */
-/* Slot 649 is reserved */
-/* Slot 650 is reserved */
-/* Slot 651 is reserved */
-/* Slot 652 is reserved */
-/* Slot 653 is reserved */
-/* Slot 654 is reserved */
-/* Slot 655 is reserved */
-/* Slot 656 is reserved */
-/* Slot 657 is reserved */
-/* Slot 658 is reserved */
-/* Slot 659 is reserved */
-/* Slot 660 is reserved */
-/* Slot 661 is reserved */
-/* Slot 662 is reserved */
-/* Slot 663 is reserved */
-/* Slot 664 is reserved */
-/* Slot 665 is reserved */
-/* Slot 666 is reserved */
-/* Slot 667 is reserved */
-/* Slot 668 is reserved */
-/* Slot 669 is reserved */
-/* Slot 670 is reserved */
-/* Slot 671 is reserved */
-/* Slot 672 is reserved */
-/* Slot 673 is reserved */
-/* Slot 674 is reserved */
-/* Slot 675 is reserved */
-/* Slot 676 is reserved */
-/* Slot 677 is reserved */
-/* Slot 678 is reserved */
-/* Slot 679 is reserved */
-/* Slot 680 is reserved */
-/* Slot 681 is reserved */
-/* Slot 682 is reserved */
-/* Slot 683 is reserved */
-/* Slot 684 is reserved */
-/* Slot 685 is reserved */
+/* 631 */
+EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
+ const char *service, const char *host,
+ unsigned int flags, int backlog,
+ Tcl_TcpAcceptProc *acceptProc,
+ void *callbackData);
+/* 632 */
+EXTERN int TclZipfs_Mount(Tcl_Interp *interp,
+ const char *mountPoint, const char *zipname,
+ const char *passwd);
+/* 633 */
+EXTERN int TclZipfs_Unmount(Tcl_Interp *interp,
+ const char *mountPoint);
+/* 634 */
+EXTERN Tcl_Obj * TclZipfs_TclLibrary(void);
+/* 635 */
+EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp,
+ const char *mountPoint, unsigned char *data,
+ size_t datalen, int copy);
+/* 636 */
+EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr);
+/* 637 */
+EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ TCL_HASH_TYPE numBytes);
+/* 638 */
+EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr);
+/* 639 */
+EXTERN void Tcl_StoreInternalRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr,
+ const Tcl_ObjInternalRep *irPtr);
+/* 640 */
+EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
+/* 641 */
+EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
+/* 642 */
+EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
+/* 643 */
+EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
+/* 644 */
+EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
+ const char *varName, void *addr, int type,
+ Tcl_Size size);
+/* 645 */
+EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Size endValue,
+ Tcl_Size *indexPtr);
+/* 646 */
+EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr);
+/* 647 */
+EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr);
+/* 648 */
+EXTERN int * Tcl_UtfToUniCharDString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr);
+/* 649 */
+EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *numBytesPtr);
+/* 650 */
+EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, size_t *numBytesPtr);
+/* 651 */
+EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr,
+ size_t *lengthPtr);
+/* 652 */
+EXTERN unsigned short * TclGetUnicodeFromObj(Tcl_Obj *objPtr,
+ size_t *lengthPtr);
+/* 653 */
+EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr,
+ size_t *numBytesPtr);
+/* 654 */
+EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length);
+/* 655 */
+EXTERN const char * Tcl_UtfNext(const char *src);
+/* 656 */
+EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
+/* 657 */
+EXTERN int Tcl_UniCharIsUnicode(int ch);
+/* 658 */
+EXTERN Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_DString *dsPtr);
+/* 659 */
+EXTERN Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_DString *dsPtr);
+/* 660 */
+EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async,
+ int sigNumber);
+/* 661 */
+EXTERN int TclListObjGetElements(Tcl_Interp *interp,
+ Tcl_Obj *listPtr, size_t *objcPtr,
+ Tcl_Obj ***objvPtr);
+/* 662 */
+EXTERN int TclListObjLength(Tcl_Interp *interp,
+ Tcl_Obj *listPtr, size_t *lengthPtr);
+/* 663 */
+EXTERN int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+ size_t *sizePtr);
+/* 664 */
+EXTERN int TclSplitList(Tcl_Interp *interp, const char *listStr,
+ size_t *argcPtr, const char ***argvPtr);
+/* 665 */
+EXTERN void TclSplitPath(const char *path, size_t *argcPtr,
+ const char ***argvPtr);
+/* 666 */
+EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr);
+/* 667 */
+EXTERN int TclParseArgsObjv(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable,
+ size_t *objcPtr, Tcl_Obj *const *objv,
+ Tcl_Obj ***remObjv);
+/* 668 */
+EXTERN Tcl_Size Tcl_UniCharLen(const int *uniStr);
+/* 669 */
+EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length);
+/* 670 */
+EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr);
+/* 671 */
+EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index);
+/* 672 */
+EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first,
+ Tcl_Size last);
+/* 673 */
+EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index);
+/* 674 */
+EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src,
+ int flags, char *charPtr);
+/* 675 */
+EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int flags, char *charPtr);
+/* 676 */
+EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc2,
+ void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 677 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp,
+ Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc2 *objProc2,
+ void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc);
+/* 678 */
+EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 679 */
+EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc2, void *clientData,
+ size_t objc, Tcl_Obj *const objv[]);
+/* 680 */
+EXTERN int Tcl_GetNumberFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, void **clientDataPtr,
+ int *typePtr);
+/* 681 */
+EXTERN int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes,
+ size_t numBytes, void **clientDataPtr,
+ int *typePtr);
+/* 682 */
+EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp,
+ Tcl_Channel chan, int mode);
+/* 683 */
+EXTERN Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
+/* 684 */
+EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
+/* 685 */
+EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr);
/* Slot 686 is reserved */
/* 687 */
EXTERN void TclUnusedStubEntry(void);
@@ -1885,22 +2060,22 @@ typedef struct TclStubs {
const TclStubHooks *hooks;
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 */
+ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
- char * (*tcl_Alloc) (unsigned int size); /* 3 */
+ char * (*tcl_Alloc) (TCL_HASH_TYPE 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 */
+ char * (*tcl_Realloc) (char *ptr, TCL_HASH_TYPE size); /* 5 */
+ char * (*tcl_DbCkalloc) (TCL_HASH_TYPE 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 */
+ char * (*tcl_DbCkrealloc) (char *ptr, TCL_HASH_TYPE 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 */
+ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
+ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
@@ -1916,27 +2091,27 @@ typedef struct TclStubs {
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 */
+ void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 16 */
+ Tcl_Obj * (*tcl_ConcatObj) (Tcl_Size 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 intValue, const char *file, int line); /* 22 */
- Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */
+ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, 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_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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_DbNewStringObj) (const char *bytes, Tcl_Size 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 *intPtr); /* 31 */
int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 32 */
- unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
+ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */
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 *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const 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 */
@@ -1946,93 +2121,93 @@ typedef struct TclStubs {
int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */
int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */
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_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size 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 */
- Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */
- Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
+ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */
+ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 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_NewLongObj) (long longValue); /* 54 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
+ Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
- Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
- void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */
- unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */
- void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int numBytes); /* 59 */
+ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */
+ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */
+ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 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_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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
+ void (*tcl_SetListObj) (Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
+ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */
+ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
- Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */
+ Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *clientData); /* 71 */
void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */
int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */
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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
+ TCL_DEPRECATED_API("Use Tcl_UtfBackslash") 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 */
+ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */
+ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *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 *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
- int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, 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 */
- void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
- void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
+ char * (*tcl_Concat) (Tcl_Size argc, const char *const *argv); /* 83 */
+ Tcl_Size (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
+ Tcl_Size (*tcl_ConvertCountedElement) (const char *src, Tcl_Size length, char *dst, int flags); /* 85 */
+ int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size argc, const char *const *argv); /* 86 */
+ int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size objc, Tcl_Obj *const objv[]); /* 87 */
+ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */
+ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */
+ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */
+ Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
+ void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */
+ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *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 *name, 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 */
+ TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, void *clientData); /* 95 */
+ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
+ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
+ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */
+ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */
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 */
+ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */
+ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */
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 */
- void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 107 */
+ void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */
+ void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */
+ void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */
void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */
void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */
void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */
- void (*tcl_DetachPids) (int numPids, Tcl_Pid *pidPtr); /* 111 */
+ void (*tcl_DetachPids) (Tcl_Size numPids, Tcl_Pid *pidPtr); /* 111 */
void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */
void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */
- void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */
+ void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *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 */
+ void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */
+ char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, Tcl_Size 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 */
void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */
void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */
- void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */
+ void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, Tcl_Size length); /* 124 */
void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
- CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */
- CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */
+ const char * (*tcl_ErrnoId) (void); /* 127 */
+ const 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_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
- void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
+ void (*tcl_EventuallyFree) (void *clientData, Tcl_FreeProc *freeProc); /* 132 */
TCL_NORETURN1 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 */
@@ -2044,49 +2219,49 @@ typedef struct TclStubs {
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
- void (*tcl_FindExecutable) (const char *argv0); /* 144 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*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 *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, 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_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
+ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
+ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
+ void * (*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 */
+ Tcl_Size (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
+ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */
+ void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
- CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
+ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
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 */
+ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
- CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
+ const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */
- Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
+ Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */
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, void **filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
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, void **filePtr); /* 167 */
#endif /* MACOSX */
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 */
+ Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
+ Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
- Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */
+ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 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 */
+ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ const 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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
@@ -2094,27 +2269,27 @@ typedef struct TclStubs {
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 */
+ char * (*tcl_JoinPath) (Tcl_Size argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
+ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *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 */
+ Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */
+ TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
+ Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */
+ char * (*tcl_Merge) (Tcl_Size argc, const 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_OpenCommandChannel) (Tcl_Interp *interp, Tcl_Size argc, const 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 flags); /* 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 */
+ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */
+ void (*tcl_Preserve) (void *data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
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 */
+ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
+ void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */
+ Tcl_Size (*tcl_Read) (Tcl_Channel chan, char *bufPtr, Tcl_Size toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */
@@ -2123,135 +2298,135 @@ typedef struct TclStubs {
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_RegExpRange) (Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 215 */
+ void (*tcl_Release) (void *clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
- int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
- int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */
- int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
+ Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
+ Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */
+ TCL_DEPRECATED_API("") 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_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
+ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */
+ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, Tcl_Size 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 */
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
- void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
- int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
+ Tcl_Size (*tcl_SetRecursionLimit) (Tcl_Interp *interp, Tcl_Size depth); /* 231 */
void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */
int (*tcl_SetServiceMode) (int mode); /* 233 */
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_SignalId) (int sig); /* 239 */
- CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
+ const char * (*tcl_SignalId) (int sig); /* 239 */
+ const 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 *prefix, 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 */
+ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
+ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
+ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 247 */
+ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *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 */
+ Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size 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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 255 */
+ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */
+ void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */
+ Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */
+ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, Tcl_Size 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 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
+ TCL_DEPRECATED_API("see TIP #422") 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, 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 */
+ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
+ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
- TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
+ TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 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, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
+ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *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);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
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 */
+ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
+ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
+ TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
+ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */
+ int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size 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 */
+ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
+ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
+ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
- void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
+ void (*tcl_FinalizeNotifier) (void *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 */
- CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
+ const 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 */
+ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, Tcl_Size offset, const char *msg, int flags, void *indexPtr); /* 304 */
+ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, Tcl_Size 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_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, 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 */
+ Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */
+ Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */
+ TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
+ TCL_DEPRECATED_API("Use Tcl_SaveInterpState") 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 */
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_UniCharToLower) (int ch); /* 321 */
- Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
- Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
+ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */
+ int (*tcl_UniCharAtIndex) (const char *src, Tcl_Size index); /* 320 */
+ int (*tcl_UniCharToLower) (int ch); /* 321 */
+ int (*tcl_UniCharToTitle) (int ch); /* 322 */
+ int (*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 */
+ const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */
+ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */
+ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
+ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ const char * (*tclUtfNext) (const char *src); /* 330 */
+ const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */
+ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
+ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size 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_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */
int (*tcl_UtfToUpper) (char *src); /* 337 */
- int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
- int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
+ Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */
+ Tcl_Size (*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_AlertNotifier) (ClientData clientData); /* 343 */
+ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
+ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
+ void (*tcl_AlertNotifier) (void *clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
int (*tcl_UniCharIsAlpha) (int ch); /* 346 */
@@ -2260,19 +2435,19 @@ 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 */
+ Tcl_Size (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */
+ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */
+ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */
+ unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size 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 */
+ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") 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, Tcl_Size length); /* 359 */
+ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
+ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
+ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 362 */
+ int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
+ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, Tcl_Size 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 */
@@ -2284,36 +2459,36 @@ typedef struct TclStubs {
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 */
+ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size 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 */
- 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 */
+ Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, Tcl_Size numChars); /* 378 */
+ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars); /* 379 */
+ Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
+ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
+ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */
+ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
- void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
+ void (*tcl_SetNotifier) (const 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_ProcObjCmd) (void *clientData, Tcl_Interp *interp, Tcl_Size 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_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
- int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
+ int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, Tcl_Size stackSize, int flags); /* 393 */
+ Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */
+ Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size 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 */
+ const 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_DEPRECATED_API("Use Tcl_ChannelClose2Proc") 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_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") 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 */
@@ -2327,24 +2502,24 @@ typedef struct TclStubs {
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_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */
+ TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *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 */
- char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */
- 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 */
- int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
+ void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */
+ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */
+ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */
+ char * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */
+ char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */
+ char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */
+ char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */
+ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size 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 */
+ unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
+ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **clientDataPtr); /* 435 */
+ TCL_DEPRECATED_API("") 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 */
@@ -2352,7 +2527,7 @@ 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_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **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 */
@@ -2368,30 +2543,30 @@ typedef struct TclStubs {
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 */
- Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, int elements); /* 460 */
+ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, Tcl_Size elements); /* 460 */
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, const Tcl_Filesystem *fsPtr); /* 465 */
+ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 464 */
+ void * (*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) (const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */
+ Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, void *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, const Tcl_Filesystem *fsPtr); /* 473 */
+ int (*tcl_FSRegister) (void *clientData, const Tcl_Filesystem *fsPtr); /* 473 */
int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */
- ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */
+ void * (*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) (const Tcl_Filesystem *fsPtr); /* 480 */
- int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */
+ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size 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 */
+ Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *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 */
@@ -2399,8 +2574,8 @@ typedef struct TclStubs {
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 */
+ long long (*tcl_Seek) (Tcl_Channel chan, long long offset, int mode); /* 491 */
+ long long (*tcl_Tell) (Tcl_Channel chan); /* 492 */
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 */
@@ -2409,12 +2584,12 @@ 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, Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
+ int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size 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, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
+ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, void *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 */
@@ -2427,13 +2602,13 @@ typedef struct TclStubs {
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 */
- Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 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 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */
+ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
+ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */
int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */
int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */
int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */
- void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */
+ void (*tcl_LimitSetCommands) (Tcl_Interp *interp, Tcl_Size commandLimit); /* 525 */
void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */
void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */
int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */
@@ -2460,43 +2635,43 @@ typedef struct TclStubs {
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
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 */
+ void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, void *clientData); /* 552 */
+ void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **clientData); /* 553 */
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 */
- 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_Obj * (*tcl_NewBignumObj) (void *value); /* 555 */
+ Tcl_Obj * (*tcl_DbNewBignumObj) (void *value, const char *file, int line); /* 556 */
+ void (*tcl_SetBignumObj) (Tcl_Obj *obj, void *value); /* 557 */
+ int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 558 */
+ int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */
+ int (*tcl_TruncateChannel) (Tcl_Channel chan, long long length); /* 560 */
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 */
void (*tcl_GetChannelError) (Tcl_Channel chan, Tcl_Obj **msg); /* 565 */
- int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, mp_int *toInit); /* 566 */
+ int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, void *toInit); /* 566 */
Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 567 */
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
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[], void *clientDataPtr); /* 573 */
+ int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, Tcl_Size 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 */
+ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length, Tcl_Size limit, const char *ellipsis); /* 575 */
+ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, Tcl_Size objc, Tcl_Obj *const objv[]); /* 576 */
+ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, Tcl_Size 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_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *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 */
+ Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *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 */
+ int (*tcl_NREvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 585 */
+ int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 586 */
+ void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 587 */
+ int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, Tcl_Size 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 */
@@ -2504,11 +2679,11 @@ typedef struct TclStubs {
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 */
+ long long (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */
+ long long (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */
+ long long (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */
+ unsigned long long (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */
+ unsigned long long (*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 */
@@ -2519,15 +2694,15 @@ typedef struct TclStubs {
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_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
+ unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, Tcl_Size len); /* 612 */
+ unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, Tcl_Size 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_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, Tcl_Size 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 */
@@ -2539,61 +2714,61 @@ typedef struct TclStubs {
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
- void (*reserved631)(void);
- void (*reserved632)(void);
- void (*reserved633)(void);
- void (*reserved634)(void);
- void (*reserved635)(void);
- void (*reserved636)(void);
- void (*reserved637)(void);
- void (*reserved638)(void);
- void (*reserved639)(void);
- void (*reserved640)(void);
- void (*reserved641)(void);
- void (*reserved642)(void);
- void (*reserved643)(void);
- void (*reserved644)(void);
- void (*reserved645)(void);
- void (*reserved646)(void);
- void (*reserved647)(void);
- void (*reserved648)(void);
- void (*reserved649)(void);
- void (*reserved650)(void);
- void (*reserved651)(void);
- void (*reserved652)(void);
- void (*reserved653)(void);
- void (*reserved654)(void);
- void (*reserved655)(void);
- void (*reserved656)(void);
- void (*reserved657)(void);
- void (*reserved658)(void);
- void (*reserved659)(void);
- void (*reserved660)(void);
- void (*reserved661)(void);
- void (*reserved662)(void);
- void (*reserved663)(void);
- void (*reserved664)(void);
- void (*reserved665)(void);
- void (*reserved666)(void);
- void (*reserved667)(void);
- void (*reserved668)(void);
- void (*reserved669)(void);
- void (*reserved670)(void);
- void (*reserved671)(void);
- void (*reserved672)(void);
- void (*reserved673)(void);
- void (*reserved674)(void);
- void (*reserved675)(void);
- void (*reserved676)(void);
- void (*reserved677)(void);
- void (*reserved678)(void);
- void (*reserved679)(void);
- void (*reserved680)(void);
- void (*reserved681)(void);
- void (*reserved682)(void);
- void (*reserved683)(void);
- void (*reserved684)(void);
- void (*reserved685)(void);
+ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, int backlog, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */
+ int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */
+ int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
+ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
+ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
+ void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */
+ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 637 */
+ Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
+ void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */
+ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
+ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
+ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
+ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
+ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */
+ int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */
+ int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
+ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */
+ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */
+ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */
+ unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */
+ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */
+ unsigned short * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */
+ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */
+ int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
+ const char * (*tcl_UtfNext) (const char *src); /* 655 */
+ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
+ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
+ Tcl_Size (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 658 */
+ Tcl_Size (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 659 */
+ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
+ int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
+ int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */
+ int (*tclDictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */
+ int (*tclSplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */
+ void (*tclSplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */
+ Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */
+ int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */
+ Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */
+ Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 669 */
+ Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */
+ const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 671 */
+ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */
+ int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */
+ int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */
+ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */
+ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
+ Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
+ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
+ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
+ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
+ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
+ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
+ Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
+ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
+ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
void (*reserved686)(void);
void (*tclUnusedStubEntry) (void); /* 687 */
} TclStubs;
@@ -2816,8 +2991,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_CreateMathFunc) /* 95 */
#define Tcl_CreateObjCommand \
(tclStubsPtr->tcl_CreateObjCommand) /* 96 */
-#define Tcl_CreateSlave \
- (tclStubsPtr->tcl_CreateSlave) /* 97 */
+#define Tcl_CreateChild \
+ (tclStubsPtr->tcl_CreateChild) /* 97 */
#define Tcl_CreateTimerHandler \
(tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
#define Tcl_CreateTrace \
@@ -2950,8 +3125,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_GetHostName) /* 162 */
#define Tcl_GetInterpPath \
(tclStubsPtr->tcl_GetInterpPath) /* 163 */
-#define Tcl_GetMaster \
- (tclStubsPtr->tcl_GetMaster) /* 164 */
+#define Tcl_GetParent \
+ (tclStubsPtr->tcl_GetParent) /* 164 */
#define Tcl_GetNameOfExecutable \
(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#define Tcl_GetObjResult \
@@ -2972,8 +3147,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_GetsObj) /* 170 */
#define Tcl_GetServiceMode \
(tclStubsPtr->tcl_GetServiceMode) /* 171 */
-#define Tcl_GetSlave \
- (tclStubsPtr->tcl_GetSlave) /* 172 */
+#define Tcl_GetChild \
+ (tclStubsPtr->tcl_GetChild) /* 172 */
#define Tcl_GetStdChannel \
(tclStubsPtr->tcl_GetStdChannel) /* 173 */
#define Tcl_GetStringResult \
@@ -3115,8 +3290,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_SplitList) /* 242 */
#define Tcl_SplitPath \
(tclStubsPtr->tcl_SplitPath) /* 243 */
-#define Tcl_StaticPackage \
- (tclStubsPtr->tcl_StaticPackage) /* 244 */
+#define Tcl_StaticLibrary \
+ (tclStubsPtr->tcl_StaticLibrary) /* 244 */
#define Tcl_StringMatch \
(tclStubsPtr->tcl_StringMatch) /* 245 */
#define Tcl_TellOld \
@@ -3278,18 +3453,18 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UniCharToUtf) /* 324 */
#define Tcl_UtfAtIndex \
(tclStubsPtr->tcl_UtfAtIndex) /* 325 */
-#define Tcl_UtfCharComplete \
- (tclStubsPtr->tcl_UtfCharComplete) /* 326 */
+#define TclUtfCharComplete \
+ (tclStubsPtr->tclUtfCharComplete) /* 326 */
#define Tcl_UtfBackslash \
(tclStubsPtr->tcl_UtfBackslash) /* 327 */
#define Tcl_UtfFindFirst \
(tclStubsPtr->tcl_UtfFindFirst) /* 328 */
#define Tcl_UtfFindLast \
(tclStubsPtr->tcl_UtfFindLast) /* 329 */
-#define Tcl_UtfNext \
- (tclStubsPtr->tcl_UtfNext) /* 330 */
-#define Tcl_UtfPrev \
- (tclStubsPtr->tcl_UtfPrev) /* 331 */
+#define TclUtfNext \
+ (tclStubsPtr->tclUtfNext) /* 330 */
+#define TclUtfPrev \
+ (tclStubsPtr->tclUtfPrev) /* 331 */
#define Tcl_UtfToExternal \
(tclStubsPtr->tcl_UtfToExternal) /* 332 */
#define Tcl_UtfToExternalDString \
@@ -3298,8 +3473,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UtfToLower) /* 334 */
#define Tcl_UtfToTitle \
(tclStubsPtr->tcl_UtfToTitle) /* 335 */
-#define Tcl_UtfToUniChar \
- (tclStubsPtr->tcl_UtfToUniChar) /* 336 */
+#define Tcl_UtfToChar16 \
+ (tclStubsPtr->tcl_UtfToChar16) /* 336 */
#define Tcl_UtfToUpper \
(tclStubsPtr->tcl_UtfToUpper) /* 337 */
#define Tcl_WriteChars \
@@ -3330,14 +3505,14 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
#define Tcl_UniCharIsWordChar \
(tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
-#define Tcl_UniCharLen \
- (tclStubsPtr->tcl_UniCharLen) /* 352 */
+#define Tcl_Char16Len \
+ (tclStubsPtr->tcl_Char16Len) /* 352 */
#define Tcl_UniCharNcmp \
(tclStubsPtr->tcl_UniCharNcmp) /* 353 */
-#define Tcl_UniCharToUtfDString \
- (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
-#define Tcl_UtfToUniCharDString \
- (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
+#define Tcl_Char16ToUtfDString \
+ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */
+#define Tcl_UtfToChar16DString \
+ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */
#define Tcl_GetRegExpFromObj \
(tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
#define Tcl_EvalTokens \
@@ -3888,61 +4063,116 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#define Tcl_ZlibStreamSetCompressionDictionary \
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
-/* Slot 631 is reserved */
-/* Slot 632 is reserved */
-/* Slot 633 is reserved */
-/* Slot 634 is reserved */
-/* Slot 635 is reserved */
-/* Slot 636 is reserved */
-/* Slot 637 is reserved */
-/* Slot 638 is reserved */
-/* Slot 639 is reserved */
-/* Slot 640 is reserved */
-/* Slot 641 is reserved */
-/* Slot 642 is reserved */
-/* Slot 643 is reserved */
-/* Slot 644 is reserved */
-/* Slot 645 is reserved */
-/* Slot 646 is reserved */
-/* Slot 647 is reserved */
-/* Slot 648 is reserved */
-/* Slot 649 is reserved */
-/* Slot 650 is reserved */
-/* Slot 651 is reserved */
-/* Slot 652 is reserved */
-/* Slot 653 is reserved */
-/* Slot 654 is reserved */
-/* Slot 655 is reserved */
-/* Slot 656 is reserved */
-/* Slot 657 is reserved */
-/* Slot 658 is reserved */
-/* Slot 659 is reserved */
-/* Slot 660 is reserved */
-/* Slot 661 is reserved */
-/* Slot 662 is reserved */
-/* Slot 663 is reserved */
-/* Slot 664 is reserved */
-/* Slot 665 is reserved */
-/* Slot 666 is reserved */
-/* Slot 667 is reserved */
-/* Slot 668 is reserved */
-/* Slot 669 is reserved */
-/* Slot 670 is reserved */
-/* Slot 671 is reserved */
-/* Slot 672 is reserved */
-/* Slot 673 is reserved */
-/* Slot 674 is reserved */
-/* Slot 675 is reserved */
-/* Slot 676 is reserved */
-/* Slot 677 is reserved */
-/* Slot 678 is reserved */
-/* Slot 679 is reserved */
-/* Slot 680 is reserved */
-/* Slot 681 is reserved */
-/* Slot 682 is reserved */
-/* Slot 683 is reserved */
-/* Slot 684 is reserved */
-/* Slot 685 is reserved */
+#define Tcl_OpenTcpServerEx \
+ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
+#define TclZipfs_Mount \
+ (tclStubsPtr->tclZipfs_Mount) /* 632 */
+#define TclZipfs_Unmount \
+ (tclStubsPtr->tclZipfs_Unmount) /* 633 */
+#define TclZipfs_TclLibrary \
+ (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */
+#define TclZipfs_MountBuffer \
+ (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */
+#define Tcl_FreeInternalRep \
+ (tclStubsPtr->tcl_FreeInternalRep) /* 636 */
+#define Tcl_InitStringRep \
+ (tclStubsPtr->tcl_InitStringRep) /* 637 */
+#define Tcl_FetchInternalRep \
+ (tclStubsPtr->tcl_FetchInternalRep) /* 638 */
+#define Tcl_StoreInternalRep \
+ (tclStubsPtr->tcl_StoreInternalRep) /* 639 */
+#define Tcl_HasStringRep \
+ (tclStubsPtr->tcl_HasStringRep) /* 640 */
+#define Tcl_IncrRefCount \
+ (tclStubsPtr->tcl_IncrRefCount) /* 641 */
+#define Tcl_DecrRefCount \
+ (tclStubsPtr->tcl_DecrRefCount) /* 642 */
+#define Tcl_IsShared \
+ (tclStubsPtr->tcl_IsShared) /* 643 */
+#define Tcl_LinkArray \
+ (tclStubsPtr->tcl_LinkArray) /* 644 */
+#define Tcl_GetIntForIndex \
+ (tclStubsPtr->tcl_GetIntForIndex) /* 645 */
+#define Tcl_UtfToUniChar \
+ (tclStubsPtr->tcl_UtfToUniChar) /* 646 */
+#define Tcl_UniCharToUtfDString \
+ (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */
+#define Tcl_UtfToUniCharDString \
+ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */
+#define TclGetBytesFromObj \
+ (tclStubsPtr->tclGetBytesFromObj) /* 649 */
+#define Tcl_GetBytesFromObj \
+ (tclStubsPtr->tcl_GetBytesFromObj) /* 650 */
+#define TclGetStringFromObj \
+ (tclStubsPtr->tclGetStringFromObj) /* 651 */
+#define TclGetUnicodeFromObj \
+ (tclStubsPtr->tclGetUnicodeFromObj) /* 652 */
+#define TclGetByteArrayFromObj \
+ (tclStubsPtr->tclGetByteArrayFromObj) /* 653 */
+#define Tcl_UtfCharComplete \
+ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */
+#define Tcl_UtfNext \
+ (tclStubsPtr->tcl_UtfNext) /* 655 */
+#define Tcl_UtfPrev \
+ (tclStubsPtr->tcl_UtfPrev) /* 656 */
+#define Tcl_UniCharIsUnicode \
+ (tclStubsPtr->tcl_UniCharIsUnicode) /* 657 */
+#define Tcl_ExternalToUtfDStringEx \
+ (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */
+#define Tcl_UtfToExternalDStringEx \
+ (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */
+#define Tcl_AsyncMarkFromSignal \
+ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */
+#define TclListObjGetElements \
+ (tclStubsPtr->tclListObjGetElements) /* 661 */
+#define TclListObjLength \
+ (tclStubsPtr->tclListObjLength) /* 662 */
+#define TclDictObjSize \
+ (tclStubsPtr->tclDictObjSize) /* 663 */
+#define TclSplitList \
+ (tclStubsPtr->tclSplitList) /* 664 */
+#define TclSplitPath \
+ (tclStubsPtr->tclSplitPath) /* 665 */
+#define TclFSSplitPath \
+ (tclStubsPtr->tclFSSplitPath) /* 666 */
+#define TclParseArgsObjv \
+ (tclStubsPtr->tclParseArgsObjv) /* 667 */
+#define Tcl_UniCharLen \
+ (tclStubsPtr->tcl_UniCharLen) /* 668 */
+#define TclNumUtfChars \
+ (tclStubsPtr->tclNumUtfChars) /* 669 */
+#define TclGetCharLength \
+ (tclStubsPtr->tclGetCharLength) /* 670 */
+#define TclUtfAtIndex \
+ (tclStubsPtr->tclUtfAtIndex) /* 671 */
+#define TclGetRange \
+ (tclStubsPtr->tclGetRange) /* 672 */
+#define TclGetUniChar \
+ (tclStubsPtr->tclGetUniChar) /* 673 */
+#define Tcl_GetBool \
+ (tclStubsPtr->tcl_GetBool) /* 674 */
+#define Tcl_GetBoolFromObj \
+ (tclStubsPtr->tcl_GetBoolFromObj) /* 675 */
+#define Tcl_CreateObjCommand2 \
+ (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */
+#define Tcl_CreateObjTrace2 \
+ (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */
+#define Tcl_NRCreateCommand2 \
+ (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
+#define Tcl_NRCallObjProc2 \
+ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */
+#define Tcl_GetNumberFromObj \
+ (tclStubsPtr->tcl_GetNumberFromObj) /* 680 */
+#define Tcl_GetNumber \
+ (tclStubsPtr->tcl_GetNumber) /* 681 */
+#define Tcl_RemoveChannelMode \
+ (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
+#define Tcl_GetEncodingNulLength \
+ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
+#define Tcl_GetWideUIntFromObj \
+ (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */
+#define Tcl_DStringToObj \
+ (tclStubsPtr->tcl_DStringToObj) /* 685 */
/* Slot 686 is reserved */
#define TclUnusedStubEntry \
(tclStubsPtr->tclUnusedStubEntry) /* 687 */
@@ -3959,24 +4189,29 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_GetStringResult
# undef Tcl_Init
# undef Tcl_SetPanicProc
-# undef Tcl_SetVar
+# undef Tcl_SetExitProc
# undef Tcl_ObjSetVar2
-# undef Tcl_StaticPackage
+# undef Tcl_StaticLibrary
# 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))
# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
(tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
#endif
#if defined(_WIN32) && defined(UNICODE)
-# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
+# if defined(TCL_NO_DEPRECATED)
+# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
+# else
+# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)((const char *)(arg))))
+# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg)))
+# endif
# define Tcl_MainEx Tcl_MainExW
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
+#elif !defined(TCL_NO_DEPRECATED)
+# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)(arg)))
+# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg)))
#endif
#undef TCL_STORAGE_CLASS
@@ -4000,13 +4235,13 @@ extern const TclStubs *tclStubsPtr;
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj(intValue) \
- Tcl_NewIntObj((intValue)!=0)
+ Tcl_NewWideIntObj((intValue)!=0)
#undef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj(intValue, file, line) \
- Tcl_DbNewLongObj((intValue)!=0, file, line)
+ Tcl_DbNewWideIntObj((intValue)!=0, file, line)
#undef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj(objPtr, intValue) \
- Tcl_SetIntObj((objPtr), (intValue)!=0)
+ Tcl_SetWideIntObj(objPtr, (intValue)!=0)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
@@ -4028,6 +4263,53 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_UpVar
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
+#undef Tcl_AddErrorInfo
+#define Tcl_AddErrorInfo(interp, message) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE))
+#undef Tcl_AddObjErrorInfo
+#define Tcl_AddObjErrorInfo(interp, message, length) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
+#ifdef TCL_NO_DEPRECATED
+#undef Tcl_FreeResult
+#undef Tcl_AppendResultVA
+#undef Tcl_AppendStringsToObjVA
+#undef Tcl_SetErrorCodeVA
+#undef Tcl_VarEvalVA
+#undef Tcl_PanicVA
+#undef Tcl_GetStringResult
+#undef Tcl_GetDefaultEncodingDir
+#undef Tcl_SetDefaultEncodingDir
+#undef Tcl_UniCharNcmp
+#undef Tcl_EvalTokens
+#undef Tcl_UniCharNcasecmp
+#undef Tcl_UniCharCaseMatch
+#undef Tcl_GetMathFuncInfo
+#undef Tcl_ListMathFuncs
+#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
+#undef Tcl_Eval
+#define Tcl_Eval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
+#undef Tcl_GlobalEval
+#define Tcl_GlobalEval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
+#undef Tcl_SaveResult
+#undef Tcl_RestoreResult
+#undef Tcl_DiscardResult
+#undef Tcl_SetResult
+#define Tcl_SetResult(interp, result, freeProc) \
+ do { \
+ const char *__result = result; \
+ Tcl_FreeProc *__freeProc = freeProc; \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \
+ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
+ if (__freeProc == TCL_DYNAMIC) { \
+ ckfree((char *)__result); \
+ } else { \
+ (*__freeProc)((char *)__result); \
+ } \
+ } \
+ } while(0)
+#endif /* TCL_NO_DEPRECATED */
#if defined(USE_TCL_STUBS)
# if defined(_WIN32) && defined(_WIN64)
@@ -4037,7 +4319,7 @@ extern const TclStubs *tclStubsPtr;
do { \
union { \
Tcl_Time now; \
- __int64 reserved; \
+ long long reserved; \
} _t; \
_t.reserved = -1; \
tclStubsPtr->tcl_GetTime((&_t.now)); \
@@ -4055,20 +4337,14 @@ extern const TclStubs *tclStubsPtr;
* possible. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
-# undef Tcl_DbNewLongObj
# undef Tcl_GetLongFromObj
-# undef Tcl_NewLongObj
-# undef Tcl_SetLongObj
# undef Tcl_ExprLong
# undef Tcl_ExprLongObj
# undef Tcl_UniCharNcmp
# undef Tcl_UtfNcmp
# undef Tcl_UtfNcasecmp
# undef Tcl_UniCharNcasecmp
-# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj)
# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
-# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
-# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
@@ -4094,18 +4370,210 @@ extern const TclStubs *tclStubsPtr;
# endif
#endif
+#undef Tcl_GetString
+#undef Tcl_GetUnicode
+#define Tcl_GetString(objPtr) \
+ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL)
+#define Tcl_GetUnicode(objPtr) \
+ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL)
+#undef Tcl_GetBytesFromObj
+#undef Tcl_GetIndexFromObjStruct
+#undef Tcl_GetBooleanFromObj
+#undef Tcl_GetBoolean
+#ifdef TCL_NO_DEPRECATED
+#undef Tcl_GetStringFromObj
+#undef Tcl_GetUnicodeFromObj
+#undef Tcl_GetByteArrayFromObj
+#endif
+#if defined(USE_TCL_STUBS)
+#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
+ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
+#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
+ (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
+ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#define Tcl_GetBoolean(interp, src, boolPtr) \
+ (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#ifdef TCL_NO_DEPRECATED
+#define Tcl_GetStringFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr)))
+#endif
+#else
+#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
+ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
+#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
+ (sizeof(*(boolPtr)) == sizeof(int) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
+ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#define Tcl_GetBoolean(interp, src, boolPtr) \
+ (sizeof(*(boolPtr)) == sizeof(int) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#ifdef TCL_NO_DEPRECATED
+#define Tcl_GetStringFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)(sizePtr)) : TclGetByteArrayFromObj(objPtr, (size_t *)(sizePtr)))
+#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : TclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr)))
+#endif
+#endif
+
+#undef Tcl_NewLongObj
+#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))
+#undef Tcl_NewIntObj
+#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
+#undef Tcl_DbNewLongObj
+#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
+#undef Tcl_SetIntObj
+#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
+#undef Tcl_SetLongObj
+#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
+#undef Tcl_BackgroundError
+#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
+#undef Tcl_StringMatch
+#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
+
+#if TCL_UTF_MAX < 4
+# undef Tcl_UniCharToUtfDString
+# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
+# undef Tcl_UtfToUniCharDString
+# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
+# undef Tcl_UtfToUniChar
+# define Tcl_UtfToUniChar Tcl_UtfToChar16
+# undef Tcl_UniCharLen
+# define Tcl_UniCharLen Tcl_Char16Len
+#elif !defined(BUILD_tcl)
+# undef Tcl_NumUtfChars
+# define Tcl_NumUtfChars TclNumUtfChars
+# undef Tcl_GetCharLength
+# define Tcl_GetCharLength TclGetCharLength
+# undef Tcl_UtfAtIndex
+# define Tcl_UtfAtIndex TclUtfAtIndex
+# undef Tcl_GetRange
+# define Tcl_GetRange TclGetRange
+# undef Tcl_GetUniChar
+# define Tcl_GetUniChar TclGetUniChar
+#endif
+#if defined(USE_TCL_STUBS)
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString)
+# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
+ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \
+ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16)
+# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
+ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \
+ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
+#ifdef TCL_NO_DEPRECATED
+# undef Tcl_ListObjGetElements
+# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
+ : tclStubsPtr->tclListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)))
+# undef Tcl_ListObjLength
+# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
+ : tclStubsPtr->tclListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)))
+# undef Tcl_DictObjSize
+# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
+ : tclStubsPtr->tclDictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)))
+# undef Tcl_SplitList
+# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_SplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
+ : tclStubsPtr->tclSplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)))
+# undef Tcl_SplitPath
+# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_SplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
+ : tclStubsPtr->tclSplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)))
+# undef Tcl_FSSplitPath
+# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
+ : tclStubsPtr->tclFSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)))
+# undef Tcl_ParseArgsObjv
+# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
+ : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)))
+#endif /* TCL_NO_DEPRECATED */
+#else
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString)
+# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
+ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \
+ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16)
+# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
+ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \
+ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
+#ifdef TCL_NO_DEPRECATED
+# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? (Tcl_ListObjGetElements)((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
+ : TclListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)))
+# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
+ ? (Tcl_ListObjLength)((interp), (listPtr), (int *)(void *)(lengthPtr)) \
+ : TclListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)))
+# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
+ ? (Tcl_DictObjSize)((interp), (dictPtr), (int *)(void *)(sizePtr)) \
+ : TclDictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)))
+# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? (Tcl_SplitList)((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
+ : TclSplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)))
+# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? (Tcl_SplitPath)((path), (int *)(void *)(argcPtr), (argvPtr)) \
+ : TclSplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)))
+# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
+ ? (Tcl_FSSplitPath)((pathPtr), (int *)(void *)(lenPtr)) \
+ : TclFSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)))
+# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? (Tcl_ParseArgsObjv)((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
+ : TclParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)))
+#endif /* TCL_NO_DEPRECATED */
+#endif
+
/*
* Deprecated Tcl procedures:
*/
+#ifdef TCL_NO_DEPRECATED
+# undef Tcl_SavedResult
+#endif /* TCL_NO_DEPRECATED */
#undef Tcl_EvalObj
-#define Tcl_EvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),0)
+#define Tcl_EvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
-#define Tcl_GlobalEvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
-#define Tcl_CreateChild Tcl_CreateSlave
-#define Tcl_GetChild Tcl_GetSlave
-#define Tcl_GetParent Tcl_GetMaster
+#define Tcl_GlobalEvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
+
+#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS)
+#undef Tcl_Close
+#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
+#endif
+
+#undef TclUtfCharComplete
+#undef TclUtfNext
+#undef TclUtfPrev
+#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED)
+# undef Tcl_UtfCharComplete
+# undef Tcl_UtfNext
+# undef Tcl_UtfPrev
+# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete)
+# define Tcl_UtfNext (tclStubsPtr->tclUtfNext)
+# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev)
+#endif
+#define Tcl_CreateSlave Tcl_CreateChild
+#define Tcl_GetSlave Tcl_GetChild
+#define Tcl_GetMaster Tcl_GetParent
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3fe1800..55664ce 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -4,14 +4,15 @@
* This file contains functions that implement the Tcl dict object type
* and its accessor command.
*
- * Copyright (c) 2002-2010 by Donal K. Fellows.
+ * Copyright © 2002-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 "tommath.h"
+#include "tclTomMath.h"
+#include <assert.h>
/*
* Forward declaration.
@@ -22,60 +23,44 @@ struct Dict;
* Prototypes for functions defined later in this file:
*/
-static void DeleteDict(struct Dict *dict);
-static int DictAppendCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictCreateCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-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 DictGetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictMergeCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictRemoveCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictReplaceCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictSetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictSizeCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictUnsetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictUpdateCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictValuesCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictWithCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static void FreeDictInternalRep(Tcl_Obj *dictPtr);
-static void InvalidateDictChain(Tcl_Obj *dictObj);
-static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void UpdateStringOfDict(Tcl_Obj *dictPtr);
-static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
-static inline void InitChainTable(struct Dict *dict);
-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 Tcl_NRPostProc FinalizeDictUpdate;
-static Tcl_NRPostProc FinalizeDictWith;
-static Tcl_ObjCmdProc DictForNRCmd;
-static Tcl_ObjCmdProc DictMapNRCmd;
-static Tcl_NRPostProc DictForLoopCallback;
-static Tcl_NRPostProc DictMapLoopCallback;
+static void DeleteDict(struct Dict *dict);
+static Tcl_ObjCmdProc DictAppendCmd;
+static Tcl_ObjCmdProc DictCreateCmd;
+static Tcl_ObjCmdProc DictExistsCmd;
+static Tcl_ObjCmdProc DictFilterCmd;
+static Tcl_ObjCmdProc DictGetCmd;
+static Tcl_ObjCmdProc DictGetDefCmd;
+static Tcl_ObjCmdProc DictIncrCmd;
+static Tcl_ObjCmdProc DictInfoCmd;
+static Tcl_ObjCmdProc DictKeysCmd;
+static Tcl_ObjCmdProc DictLappendCmd;
+static Tcl_ObjCmdProc DictMergeCmd;
+static Tcl_ObjCmdProc DictRemoveCmd;
+static Tcl_ObjCmdProc DictReplaceCmd;
+static Tcl_ObjCmdProc DictSetCmd;
+static Tcl_ObjCmdProc DictSizeCmd;
+static Tcl_ObjCmdProc DictUnsetCmd;
+static Tcl_ObjCmdProc DictUpdateCmd;
+static Tcl_ObjCmdProc DictValuesCmd;
+static Tcl_ObjCmdProc DictWithCmd;
+static Tcl_DupInternalRepProc DupDictInternalRep;
+static Tcl_FreeInternalRepProc FreeDictInternalRep;
+static void InvalidateDictChain(Tcl_Obj *dictObj);
+static Tcl_SetFromAnyProc SetDictFromAny;
+static Tcl_UpdateStringProc UpdateStringOfDict;
+static Tcl_AllocHashEntryProc AllocChainEntry;
+static inline void InitChainTable(struct Dict *dict);
+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 Tcl_NRPostProc FinalizeDictUpdate;
+static Tcl_NRPostProc FinalizeDictWith;
+static Tcl_ObjCmdProc DictForNRCmd;
+static Tcl_ObjCmdProc DictMapNRCmd;
+static Tcl_NRPostProc DictForLoopCallback;
+static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
@@ -88,6 +73,9 @@ static const EnsembleImplMap implementationMap[] = {
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
+ {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
+ {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd,
+ NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
@@ -141,7 +129,7 @@ typedef struct Dict {
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
- int epoch; /* Epoch counter */
+ TCL_HASH_TYPE epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
@@ -149,13 +137,6 @@ typedef struct Dict {
} Dict;
/*
- * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
- * must be assignable as well as readable.
- */
-
-#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1)
-
-/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
@@ -168,6 +149,21 @@ const Tcl_ObjType tclDictType = {
SetDictFromAny /* setFromAnyProc */
};
+#define DictSetInternalRep(objPtr, dictRepPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (dictRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
+ } while (0)
+
+#define DictGetInternalRep(objPtr, dictRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
+ (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
@@ -226,16 +222,16 @@ typedef struct {
static Tcl_HashEntry *
AllocChainEntry(
- Tcl_HashTable *tablePtr,
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr)
{
- Tcl_Obj *objPtr = keyPtr;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
ChainEntry *cPtr;
- cPtr = ckalloc(sizeof(ChainEntry));
+ cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry));
cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
- cPtr->entry.clientData = NULL;
+ Tcl_SetHashValue(&cPtr->entry, NULL);
cPtr->prevPtr = cPtr->nextPtr = NULL;
return &cPtr->entry;
@@ -363,10 +359,11 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = DICT(srcPtr);
- Dict *newDict = (Dict *)ckalloc(sizeof(Dict));
+ Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict));
ChainEntry *cPtr;
+ DictGetInternalRep(srcPtr, oldDict);
+
/*
* Copy values across from the old hash table.
*/
@@ -390,7 +387,7 @@ DupDictInternalRep(
* Initialise other fields.
*/
- newDict->epoch = 0;
+ newDict->epoch = 1;
newDict->chain = NULL;
newDict->refCount = 1;
@@ -398,9 +395,7 @@ DupDictInternalRep(
* Store in the object.
*/
- DICT(copyPtr) = newDict;
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- copyPtr->typePtr = &tclDictType;
+ DictSetInternalRep(copyPtr, newDict);
}
/*
@@ -425,12 +420,13 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = DICT(dictPtr);
+ Dict *dict;
+
+ DictGetInternalRep(dictPtr, dict);
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
- dictPtr->typePtr = NULL;
}
/*
@@ -489,11 +485,11 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = DICT(dictPtr);
+ Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length;
- unsigned int bytesNeeded = 0;
+ TCL_HASH_TYPE bytesNeeded = 0;
const char *elem;
char *dst;
@@ -502,12 +498,17 @@ UpdateStringOfDict(
* is not exposed by any API function...
*/
- int numElems = dict->table.numEntries * 2;
+ int numElems;
+
+ DictGetInternalRep(dictPtr, dict);
+
+ assert (dict != NULL);
+
+ numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
- dictPtr->bytes = tclEmptyStringRep;
- dictPtr->length = 0;
+ Tcl_InitStringRep(dictPtr, NULL, 0);
return;
}
@@ -551,9 +552,8 @@ UpdateStringOfDict(
* Pass 2: copy into string rep buffer.
*/
- dictPtr->length = bytesNeeded - 1;
- dictPtr->bytes = ckalloc(bytesNeeded);
- dst = dictPtr->bytes;
+ dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
+ TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
@@ -567,7 +567,8 @@ UpdateStringOfDict(
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
- dictPtr->bytes[dictPtr->length] = '\0';
+ /* Last space overwrote the terminating NUL; cal T_ISR again to restore */
+ (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
ckfree(flagPtr);
@@ -611,12 +612,12 @@ SetDictFromAny(
* the conversion from lists to dictionaries.
*/
- if (objPtr->typePtr == &tclListType) {
+ if (TclHasInternalRep(objPtr, &tclListType)) {
int objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
- TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
}
@@ -649,7 +650,8 @@ SetDictFromAny(
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
- int elemSize, literal;
+ int elemSize;
+ int literal;
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
&elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
@@ -666,10 +668,14 @@ SetDictFromAny(
TclNewStringObj(keyPtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(keyPtr);
- keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
- keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
- keyPtr->bytes);
+ Tcl_InvalidateStringRep(keyPtr);
+ dst = Tcl_InitStringRep(keyPtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(keyPtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
@@ -682,10 +688,14 @@ SetDictFromAny(
TclNewStringObj(valuePtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(valuePtr);
- valuePtr->bytes = ckalloc((unsigned) elemSize + 1);
- valuePtr->length = TclCopyAndCollapse(elemSize, elemStart,
- valuePtr->bytes);
+ Tcl_InvalidateStringRep(valuePtr);
+ dst = Tcl_InitStringRep(valuePtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(valuePtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
@@ -707,13 +717,10 @@ SetDictFromAny(
* Tcl_GetStringFromObj, to use that old internalRep.
*/
- TclFreeIntRep(objPtr);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(objPtr) = dict;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclDictType;
+ DictSetInternalRep(objPtr, dict);
return TCL_OK;
missingValue:
@@ -727,6 +734,23 @@ SetDictFromAny(
ckfree(dict);
return TCL_ERROR;
}
+
+static Dict *
+GetDictFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr)
+{
+ Dict *dict;
+
+ DictGetInternalRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetInternalRep(dictPtr, dict);
+ }
+ return dict;
+}
/*
*----------------------------------------------------------------------
@@ -771,11 +795,13 @@ TclTraceDictPath(
Dict *dict, *newDict;
int i;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
- return NULL;
+ DictGetInternalRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetInternalRep(dictPtr, dict);
}
- dict = DICT(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -811,13 +837,17 @@ TclTraceDictPath(
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
- if (tmpObj->typePtr != &tclDictType
- && SetDictFromAny(interp, tmpObj) != TCL_OK) {
- return NULL;
+
+ DictGetInternalRep(tmpObj, newDict);
+
+ if (newDict == NULL) {
+ if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
+ }
}
}
- newDict = DICT(tmpObj);
+ DictGetInternalRep(tmpObj, newDict);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -825,7 +855,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = DICT(tmpObj);
+ DictGetInternalRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
@@ -860,17 +890,24 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = DICT(dictObj);
+ Dict *dict;
+
+ DictGetInternalRep(dictObj, dict);
+ assert( dict != NULL);
do {
+ dict->refCount++;
TclInvalidateStringRep(dictObj);
+ TclFreeInternalRep(dictObj);
+ DictSetInternalRep(dictObj, dict);
+
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = DICT(dictObj);
+ DictGetInternalRep(dictObj, dict);
} while (dict != NULL);
}
@@ -908,16 +945,16 @@ Tcl_DictObjPut(
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
- dict = DICT(dictPtr);
+ TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
+ dict->refCount++;
+ TclFreeInternalRep(dictPtr)
+ DictSetInternalRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
@@ -959,13 +996,12 @@ Tcl_DictObjGet(
Dict *dict;
Tcl_HashEntry *hPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
*valuePtrPtr = NULL;
return TCL_ERROR;
}
- dict = DICT(dictPtr);
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1006,16 +1042,13 @@ Tcl_DictObjRemove(
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
if (DeleteChainEntry(dict, keyPtr)) {
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
dict->epoch++;
}
return TCL_OK;
@@ -1039,6 +1072,7 @@ Tcl_DictObjRemove(
*----------------------------------------------------------------------
*/
+#undef Tcl_DictObjSize
int
Tcl_DictObjSize(
Tcl_Interp *interp,
@@ -1047,12 +1081,11 @@ Tcl_DictObjSize(
{
Dict *dict;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1099,15 +1132,14 @@ Tcl_DictObjFirst(
Dict *dict;
ChainEntry *cPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
- searchPtr->epoch = -1;
+ searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
@@ -1168,7 +1200,7 @@ Tcl_DictObjNext(
* If the searh is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
@@ -1225,8 +1257,8 @@ Tcl_DictObjDone(
{
Dict *dict;
- if (searchPtr->epoch != -1) {
- searchPtr->epoch = -1;
+ if (searchPtr->epoch) {
+ searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
DeleteDict(dict);
@@ -1278,11 +1310,12 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
- Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
@@ -1335,7 +1368,8 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1376,14 +1410,12 @@ Tcl_NewDictObj(void)
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
- dict = ckalloc(sizeof(Dict));
+ dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetInternalRep(dictPtr, dict);
return dictPtr;
#endif
}
@@ -1415,30 +1447,34 @@ Tcl_NewDictObj(void)
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
-#ifdef TCL_MEM_DEBUG
Tcl_Obj *dictPtr;
Dict *dict;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
- dict = ckalloc(sizeof(Dict));
+ dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetInternalRep(dictPtr, dict);
return dictPtr;
+}
#else /* !TCL_MEM_DEBUG */
+Tcl_Obj *
+Tcl_DbNewDictObj(
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
return Tcl_NewDictObj();
-#endif
}
+#endif
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
@@ -1462,7 +1498,7 @@ Tcl_DbNewDictObj(
static int
DictCreateCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1512,7 +1548,7 @@ DictCreateCmd(
static int
DictGetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1588,6 +1624,71 @@ DictGetCmd(
/*
*----------------------------------------------------------------------
*
+ * DictGetDefCmd --
+ *
+ * This function implements the "dict getdef" and "dict getwithdefault"
+ * Tcl commands. See the user documentation for details on what it does,
+ * and TIP#342 for the formal specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictGetDefCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
+ Tcl_Obj *const *keyPath;
+ int numKeys;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Give the bits of arguments names for clarity.
+ */
+
+ dictPtr = objv[1];
+ keyPath = &objv[2];
+ numKeys = objc - 4; /* Number of keys in keyPath; there's always
+ * one extra key afterwards too. */
+ keyPtr = objv[objc - 2];
+ defaultPtr = objv[objc - 1];
+
+ /*
+ * Implement the getting-with-default operation.
+ */
+
+ dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath,
+ DICT_PATH_EXISTS);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ } else if (dictPtr == DICT_PATH_NON_EXISTENT) {
+ Tcl_SetObjResult(interp, defaultPtr);
+ } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
+ return TCL_ERROR;
+ } else if (valuePtr == NULL) {
+ Tcl_SetObjResult(interp, defaultPtr);
+ } else {
+ Tcl_SetObjResult(interp, valuePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
@@ -1605,7 +1706,7 @@ DictGetCmd(
static int
DictReplaceCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1619,16 +1720,13 @@ DictReplaceCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i+=2) {
Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
}
@@ -1656,7 +1754,7 @@ DictReplaceCmd(
static int
DictRemoveCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1670,16 +1768,13 @@ DictRemoveCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i++) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
@@ -1707,7 +1802,7 @@ DictRemoveCmd(
static int
DictMergeCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1730,8 +1825,7 @@ DictMergeCmd(
*/
targetObj = objv[1];
- if (targetObj->typePtr != &tclDictType
- && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ if (GetDictFromObj(interp, targetObj) == NULL) {
return TCL_ERROR;
}
@@ -1795,7 +1889,7 @@ DictMergeCmd(
static int
DictKeysCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1814,8 +1908,7 @@ DictKeysCmd(
* need. [Bug 1705778, leak K04]
*/
- if (objv[1]->typePtr != &tclDictType
- && SetDictFromAny(interp, objv[1]) != TCL_OK) {
+ if (GetDictFromObj(interp, objv[1]) == NULL) {
return TCL_ERROR;
}
@@ -1875,7 +1968,7 @@ DictKeysCmd(
static int
DictValuesCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1935,12 +2028,13 @@ DictValuesCmd(
static int
DictSizeCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- int result, size;
+ int result;
+ int size;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
@@ -1948,7 +2042,7 @@ DictSizeCmd(
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
}
return result;
}
@@ -1973,7 +2067,7 @@ DictSizeCmd(
static int
DictExistsCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1985,11 +2079,9 @@ DictExistsCmd(
return TCL_ERROR;
}
- dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2,
- DICT_PATH_EXISTS);
- if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT
- || Tcl_DictObjGet(interp, dictPtr, objv[objc-1],
- &valuePtr) != TCL_OK) {
+ dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS);
+ if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT ||
+ Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
@@ -2017,12 +2109,11 @@ DictExistsCmd(
static int
DictInfoCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *dictPtr;
Dict *dict;
char *statsStr;
@@ -2031,12 +2122,10 @@ DictInfoCmd(
return TCL_ERROR;
}
- dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, objv[1]);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = DICT(dictPtr);
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2064,7 +2153,7 @@ DictInfoCmd(
static int
DictIncrCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2097,12 +2186,11 @@ DictIncrCmd(
* soon be no good.
*/
- char *saved = dictPtr->bytes;
Tcl_Obj *oldPtr = dictPtr;
- dictPtr->bytes = NULL;
- dictPtr = Tcl_DuplicateObj(dictPtr);
- oldPtr->bytes = saved;
+ TclNewObj(dictPtr);
+ TclInvalidateStringRep(dictPtr);
+ DupDictInternalRep(oldPtr, dictPtr);
}
if (valuePtr == NULL) {
/*
@@ -2129,7 +2217,7 @@ DictIncrCmd(
Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
}
} else {
- Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewWideIntObj(1));
}
} else {
/*
@@ -2186,7 +2274,7 @@ DictIncrCmd(
static int
DictLappendCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2240,7 +2328,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
- } else if (dictPtr->bytes != NULL) {
+ } else {
TclInvalidateStringRep(dictPtr);
}
@@ -2273,13 +2361,13 @@ DictLappendCmd(
static int
DictAppendCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
- int i, allocatedDict = 0;
+ int allocatedDict = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
@@ -2302,17 +2390,49 @@ DictAppendCmd(
return TCL_ERROR;
}
- if (valuePtr == NULL) {
- TclNewObj(valuePtr);
- } else if (Tcl_IsShared(valuePtr)) {
- valuePtr = Tcl_DuplicateObj(valuePtr);
- }
+ if ((objc > 3) || (valuePtr == NULL)) {
+ /* Only go through append activites when something will change. */
+ Tcl_Obj *appendObjPtr = NULL;
+
+ if (objc > 3) {
+ /* Something to append */
- for (i=3 ; i<objc ; i++) {
- Tcl_AppendObjToObj(valuePtr, objv[i]);
+ if (objc == 4) {
+ appendObjPtr = objv[3];
+ } else {
+ appendObjPtr = TclStringCat(interp, objc-3, objv+3,
+ TCL_STRING_IN_PLACE);
+ if (appendObjPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ if (appendObjPtr == NULL) {
+ /* => (objc == 3) => (valuePtr == NULL) */
+ TclNewObj(valuePtr);
+ } else if (valuePtr == NULL) {
+ valuePtr = appendObjPtr;
+ appendObjPtr = NULL;
+ }
+
+ if (appendObjPtr) {
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ }
+
+ Tcl_IncrRefCount(appendObjPtr);
+ Tcl_AppendObjToObj(valuePtr, appendObjPtr);
+ Tcl_DecrRefCount(appendObjPtr);
+ }
+
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
- Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+ /*
+ * Even if nothing changed, we still overwrite so that variable
+ * trace expectations are met.
+ */
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
@@ -2343,7 +2463,7 @@ DictAppendCmd(
static int
DictForNRCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2352,7 +2472,8 @@ DictForNRCmd(
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
Tcl_DictSearch *searchPtr;
- int varc, done;
+ int varc;
+ int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2364,7 +2485,7 @@ DictForNRCmd(
* Parse arguments.
*/
- if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
@@ -2373,7 +2494,7 @@ DictForNRCmd(
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
- searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
+ searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
@@ -2383,7 +2504,7 @@ DictForNRCmd(
TclStackFree(interp, searchPtr);
return TCL_OK;
}
- TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[3];
@@ -2438,15 +2559,15 @@ DictForNRCmd(
static int
DictForLoopCallback(
- ClientData data[],
+ void *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_DictSearch *searchPtr = (Tcl_DictSearch *)data[0];
+ Tcl_Obj *keyVarObj = (Tcl_Obj *)data[1];
+ Tcl_Obj *valueVarObj = (Tcl_Obj *)data[2];
+ Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj *keyObj, *valueObj;
int done;
@@ -2538,7 +2659,7 @@ DictForLoopCallback(
static int
DictMapNRCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2546,7 +2667,8 @@ DictMapNRCmd(
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
- int varc, done;
+ int varc;
+ int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2558,7 +2680,7 @@ DictMapNRCmd(
* Parse arguments.
*/
- if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
@@ -2567,7 +2689,7 @@ DictMapNRCmd(
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
- storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
+ storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
&valueObj, &done) != TCL_OK) {
TclStackFree(interp, storagePtr);
@@ -2584,7 +2706,7 @@ DictMapNRCmd(
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
- TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
storagePtr->keyVarObj = varv[0];
storagePtr->valueVarObj = varv[1];
storagePtr->scriptObj = objv[3];
@@ -2642,12 +2764,12 @@ DictMapNRCmd(
static int
DictMapLoopCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- DictMapStorage *storagePtr = data[0];
+ DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
@@ -2750,7 +2872,7 @@ DictMapLoopCallback(
static int
DictSetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2810,7 +2932,7 @@ DictSetCmd(
static int
DictUnsetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2869,7 +2991,7 @@ DictUnsetCmd(
static int
DictFilterCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2884,7 +3006,8 @@ DictFilterCmd(
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
- int index, varc, done, result, satisfied;
+ int index, done, result, satisfied;
+ int varc;
const char *pattern;
if (objc < 3) {
@@ -2997,7 +3120,7 @@ DictFilterCmd(
* copying from the "dict for" implementation has occurred!
*/
- if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
@@ -3154,14 +3277,15 @@ DictFilterCmd(
static int
DictUpdateCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
- int i, dummy;
+ int i;
+ int dummy;
if (objc < 5 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -3184,7 +3308,7 @@ DictUpdateCmd(
}
if (objPtr == NULL) {
/* ??? */
- Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
+ Tcl_UnsetVar2(interp, Tcl_GetString(objv[i+1]), NULL, 0);
} else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(dictPtr);
@@ -3208,15 +3332,15 @@ DictUpdateCmd(
static int
FinalizeDictUpdate(
- ClientData data[],
+ void *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];
+ Tcl_Obj *varName = (Tcl_Obj *)data[0];
+ Tcl_Obj *argsObj = (Tcl_Obj *)data[1];
/*
* ErrorInfo handling.
@@ -3258,7 +3382,7 @@ FinalizeDictUpdate(
* an instruction to remove the key.
*/
- TclListObjGetElements(NULL, argsObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, argsObj, &objc, &objv);
for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
@@ -3312,7 +3436,7 @@ FinalizeDictUpdate(
static int
DictWithCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3359,16 +3483,16 @@ DictWithCmd(
static int
FinalizeDictWith(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
- Tcl_Obj *varName = data[0];
- Tcl_Obj *keysPtr = data[1];
- Tcl_Obj *pathPtr = data[2];
+ Tcl_Obj *varName = (Tcl_Obj *)data[0];
+ Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
+ Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
@@ -3382,7 +3506,7 @@ FinalizeDictWith(
state = Tcl_SaveInterpState(interp, result);
if (pathPtr != NULL) {
- TclListObjGetElements(NULL, pathPtr, &pathc, &pathv);
+ TclListObjGetElementsM(NULL, pathPtr, &pathc, &pathv);
} else {
pathc = 0;
pathv = NULL;
@@ -3588,7 +3712,7 @@ TclDictWithFinish(
* Now process our updates on the leaf dictionary.
*/
- TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
+ TclListObjGetElementsM(NULL, keysPtr, &keyc, &keyv);
for (i=0 ; i<keyc ; i++) {
valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
if (valPtr == NULL) {
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 4a61f69..0bc3de1 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -4,9 +4,9 @@
* This file contains procedures that disassemble bytecode into either
* human-readable or Tcl-processable forms.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2013-2016 Donal K. Fellows.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2013-2016 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,10 +21,8 @@
* Prototypes for procedures defined later in this file:
*/
-static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
+static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
+static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
static void GetLocationInformation(Proc *procPtr,
@@ -38,7 +36,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr);
* reporting of inner contexts in errorstack without string allocation.
*/
-static const Tcl_ObjType tclInstNameType = {
+static const Tcl_ObjType instNameType = {
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
@@ -46,12 +44,21 @@ static const Tcl_ObjType tclInstNameType = {
NULL, /* setFromAnyProc */
};
-/*
- * How to get the bytecode out of a Tcl_Obj.
- */
+#define InstNameSetInternalRep(objPtr, inst) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.wideValue = (inst); \
+ Tcl_StoreInternalRep((objPtr), &instNameType, &ir); \
+ } while (0)
+
+#define InstNameGetInternalRep(objPtr, inst) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &instNameType); \
+ assert(irPtr != NULL); \
+ (inst) = (size_t)irPtr->wideValue; \
+ } while (0)
-#define BYTECODE(objPtr) \
- ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
/*
*----------------------------------------------------------------------
@@ -123,10 +130,10 @@ GetLocationInformation(
void
TclPrintByteCodeObj(
- Tcl_Interp *interp, /* Used only for getting location info. */
+ TCL_UNUSED(Tcl_Interp *), /* Stuck with this in internal stubs */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr);
+ Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
@@ -191,7 +198,7 @@ TclPrintObject(
char *bytes;
int length;
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
@@ -242,20 +249,22 @@ TclPrintSource(
static Tcl_Obj *
DisassembleByteCodeObj(
- Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
- Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ Interp *iPtr;
Tcl_Obj *bufferObj, *fileObj;
- char ptrBuf1[20], ptrBuf2[20];
+
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+
+ iPtr = (Interp *) *codePtr->interpHandle;
TclNewObj(bufferObj);
- if (codePtr->refCount <= 0) {
+ if (!codePtr->refCount) {
return bufferObj; /* Already freed. */
}
@@ -267,17 +276,15 @@ DisassembleByteCodeObj(
* Print header lines describing the ByteCode.
*/
- sprintf(ptrBuf1, "%p", codePtr);
- sprintf(ptrBuf2, "%p", iPtr);
Tcl_AppendPrintfToObj(bufferObj,
- "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
- ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
+ "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n",
+ codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
- if (line > -1 && fileObj != NULL) {
+ if (line >= 0 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
Tcl_GetString(fileObj), line);
}
@@ -294,13 +301,14 @@ DisassembleByteCodeObj(
#ifdef TCL_COMPILE_STATS
Tcl_AppendPrintfToObj(bufferObj,
- " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
- (unsigned long) codePtr->structureSize,
- (unsigned long) (TclOffset(ByteCode, localCachePtr)),
+ " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %d+litObj %"
+ TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n",
+ codePtr->structureSize,
+ offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
- (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
- (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
- (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numLitObjects * sizeof(Tcl_Obj *),
+ codePtr->numExceptRanges*sizeof(ExceptionRange),
+ codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
@@ -314,10 +322,9 @@ DisassembleByteCodeObj(
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- sprintf(ptrBuf1, "%p", procPtr);
Tcl_AppendPrintfToObj(bufferObj,
- " Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
- ptrBuf1, procPtr->refCount, procPtr->numArgs,
+ " Proc %p, refCt %u, args %d, compiled locals %d\n",
+ procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
@@ -648,7 +655,7 @@ FormatInstruction(
int length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
- bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
+ bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
@@ -758,7 +765,7 @@ TclGetInnerContext(
* Reset while keeping the list internalrep as much as possible.
*/
- TclListObjLength(interp, result, &len);
+ TclListObjLengthM(interp, result, &len);
Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
}
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
@@ -801,9 +808,8 @@ TclNewInstNameObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- objPtr->typePtr = &tclInstNameType;
- objPtr->internalRep.longValue = (long) inst;
- objPtr->bytes = NULL;
+ TclInvalidateStringRep(objPtr);
+ InstNameSetInternalRep(objPtr, inst);
return objPtr;
}
@@ -822,20 +828,22 @@ static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
- int inst = objPtr->internalRep.longValue;
- char *s, buf[20];
- int len;
+ size_t inst; /* NOTE: We know this is really an unsigned char */
+ char *dst;
+
+ InstNameGetInternalRep(objPtr, inst);
- if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
- sprintf(buf, "inst_%d", inst);
- s = buf;
+ if (inst > LAST_INST_OPCODE) {
+ dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
+ TclOOM(dst, TCL_INTEGER_SPACE + 5);
+ sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
- s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
+ const char *s = tclInstructionTable[inst].name;
+ unsigned int len = strlen(s);
+ dst = Tcl_InitStringRep(objPtr, s, len);
+ TclOOM(dst, len);
}
- len = strlen(s);
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, s, len + 1);
- objPtr->length = len;
}
/*
@@ -929,17 +937,17 @@ PrintSourceToObj(
static Tcl_Obj *
DisassembleByteCodeAsDicts(
- Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
- * procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
int i, val, line;
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+
/*
* Get the literals from the bytecode.
*/
@@ -1028,7 +1036,7 @@ DisassembleByteCodeAsDicts(
val = TclGetUInt4AtPtr(opnd);
opnd += 4;
formatNumber:
- Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+ Tcl_ListObjAppendElement(NULL, inst, Tcl_NewWideIntObj(val));
break;
case OPERAND_OFFSET1:
@@ -1096,7 +1104,7 @@ DisassembleByteCodeAsDicts(
Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
}
}
- Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst);
+ Tcl_DictObjPut(NULL, instructions, Tcl_NewWideIntObj(address), inst);
pc += instDesc->numBytes;
}
@@ -1181,9 +1189,9 @@ DisassembleByteCodeAsDicts(
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
- Tcl_NewIntObj(codeOffset));
+ Tcl_NewWideIntObj(codeOffset));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
- Tcl_NewIntObj(codeOffset + codeLength - 1));
+ Tcl_NewWideIntObj(codeOffset + codeLength - 1));
/*
* Convert byte offsets to character offsets; important if multibyte
@@ -1191,10 +1199,10 @@ DisassembleByteCodeAsDicts(
*/
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
- Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+ Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
- Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+ Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset + sourceLength - 1)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
@@ -1230,13 +1238,13 @@ DisassembleByteCodeAsDicts(
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
- Tcl_NewIntObj(codePtr->maxStackDepth));
+ Tcl_NewWideIntObj(codePtr->maxStackDepth));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
- Tcl_NewIntObj(codePtr->maxExceptDepth));
- if (line > -1) {
+ Tcl_NewWideIntObj(codePtr->maxExceptDepth));
+ if (line >= 0) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("initiallinenumber", -1),
- Tcl_NewIntObj(line));
+ Tcl_NewWideIntObj(line));
}
if (file) {
Tcl_DictObjPut(NULL, description,
@@ -1279,6 +1287,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ ByteCode *codePtr;
Method *methodPtr;
if (objc < 2) {
@@ -1297,27 +1306,19 @@ Tcl_DisassembleObjCmd(
/*
* Compile (if uncompiled) and disassemble a lambda term.
- *
- * WARNING! Pokes inside the lambda objtype.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
return TCL_ERROR;
}
- if (objv[2]->typePtr == &tclLambdaType) {
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
- }
- if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
- result = tclLambdaType.setFromAnyProc(interp, objv[2]);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+
+ procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr);
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
memset(&cmd, 0, sizeof(Command));
- nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
@@ -1367,8 +1368,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if ((objv[2]->typePtr != &tclByteCodeType)
- && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+
+ if (!TclHasInternalRep(objv[2], &tclByteCodeType) && (TCL_OK
+ != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) {
return TCL_ERROR;
}
codeObjPtr = objv[2];
@@ -1418,7 +1420,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1483,7 +1485,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1560,7 +1562,7 @@ Tcl_DisassembleObjCmd(
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
@@ -1568,7 +1570,7 @@ Tcl_DisassembleObjCmd(
"METHODTYPE", NULL);
return TCL_ERROR;
}
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1596,19 +1598,21 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
+ ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);
+
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
}
- if (PTR2INT(clientData)) {
+ if (clientData) {
Tcl_SetObjResult(interp,
- DisassembleByteCodeAsDicts(interp, codeObjPtr));
+ DisassembleByteCodeAsDicts(codeObjPtr));
} else {
Tcl_SetObjResult(interp,
- DisassembleByteCodeObj(interp, codeObjPtr));
+ DisassembleByteCodeObj(codeObjPtr));
}
return TCL_OK;
}
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index dfa7907..288b07c 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -3,13 +3,14 @@
*
* Contains the implementation of the encoding conversion package.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
+#include "tclIO.h"
typedef size_t (LengthProc)(const char *src);
@@ -33,20 +34,22 @@ typedef struct {
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
+ void *clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion functions. */
int nullSize; /* Number of 0x00 bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
- * negative. This number can be 1 or 2. */
- ClientData clientData; /* Arbitrary value associated with encoding
- * type. Passed to conversion functions. */
+ * negative. This number can be 1, 2, or 4. */
LengthProc *lengthProc; /* Function to compute length of
* null-terminated strings in this encoding.
* If nullSize is 1, this is strlen; if
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
- * terminated string. */
- int refCount; /* Number of uses of this structure. */
+ * terminated string; if nullSize is 4, this
+ * is a function that returns the number of
+ * bytes in a 0x00000000 terminated string. */
+ size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -214,51 +217,18 @@ static Tcl_Encoding LoadEscapeEncoding(const char *name,
static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp,
const char *name);
static Tcl_EncodingFreeProc TableFreeProc;
-static int TableFromUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int TableToUtfProc(ClientData clientData, const char *src,
- int srcLen, int flags, Tcl_EncodingState *statePtr,
- char *dst, int dstLen, int *srcReadPtr,
- int *dstWrotePtr, int *dstCharsPtr);
+static Tcl_EncodingConvertProc TableFromUtfProc;
+static Tcl_EncodingConvertProc TableToUtfProc;
static size_t unilen(const char *src);
-static int UnicodeToUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int UtfToUnicodeProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int UtfToUtfProc(ClientData clientData,
- 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,
- 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,
- 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,
- 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,
- Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
+static size_t unilen4(const char *src);
+static Tcl_EncodingConvertProc Utf32ToUtfProc;
+static Tcl_EncodingConvertProc UtfToUtf32Proc;
+static Tcl_EncodingConvertProc Utf16ToUtfProc;
+static Tcl_EncodingConvertProc UtfToUtf16Proc;
+static Tcl_EncodingConvertProc UtfToUcs2Proc;
+static Tcl_EncodingConvertProc UtfToUtfProc;
+static Tcl_EncodingConvertProc Iso88591FromUtfProc;
+static Tcl_EncodingConvertProc Iso88591ToUtfProc;
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
@@ -269,6 +239,21 @@ static int Iso88591ToUtfProc(ClientData clientData,
static const Tcl_ObjType encodingType = {
"encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL
};
+#define EncodingSetInternalRep(objPtr, encoding) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (encoding); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &encodingType, &ir); \
+ } while (0)
+
+#define EncodingGetInternalRep(objPtr, encoding) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep ((objPtr), &encodingType); \
+ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -295,17 +280,16 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
+ Tcl_Encoding encoding;
const char *name = TclGetString(objPtr);
- if (objPtr->typePtr != &encodingType) {
- Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
-
+ EncodingGetInternalRep(objPtr, encoding);
+ if (encoding == NULL) {
+ encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = encoding;
- objPtr->typePtr = &encodingType;
+ EncodingSetInternalRep(objPtr, encoding);
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -325,8 +309,10 @@ static void
FreeEncodingInternalRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding((Tcl_Encoding)objPtr->internalRep.twoPtrValue.ptr1);
- objPtr->typePtr = NULL;
+ Tcl_Encoding encoding;
+
+ EncodingGetInternalRep(objPtr, encoding);
+ Tcl_FreeEncoding(encoding);
}
/*
@@ -344,7 +330,8 @@ DupEncodingInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr));
+ EncodingSetInternalRep(dupPtr, encoding);
}
/*
@@ -384,7 +371,7 @@ Tcl_SetEncodingSearchPath(
{
int dummy;
- if (TCL_ERROR == TclListObjLength(NULL, searchPath, &dummy)) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) {
return TCL_ERROR;
}
TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);
@@ -431,7 +418,7 @@ TclSetLibraryPath(
{
int dummy;
- if (TCL_ERROR == TclListObjLength(NULL, path, &dummy)) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, path, &dummy)) {
return;
}
TclSetProcessGlobalValue(&libraryPath, path, NULL);
@@ -470,7 +457,7 @@ FillEncodingFileMap(void)
searchPath = Tcl_GetEncodingSearchPath();
Tcl_IncrRefCount(searchPath);
- TclListObjLength(NULL, searchPath, &numDirs);
+ TclListObjLengthM(NULL, searchPath, &numDirs);
map = Tcl_NewDictObj();
Tcl_IncrRefCount(map);
@@ -494,7 +481,7 @@ FillEncodingFileMap(void)
Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
&readableFiles);
- TclListObjGetElements(NULL, matchFileList, &numFiles, &filev);
+ TclListObjGetElementsM(NULL, matchFileList, &numFiles, &filev);
for (j=0; j<numFiles; j++) {
Tcl_Obj *encodingName, *fileObj;
@@ -529,6 +516,11 @@ FillEncodingFileMap(void)
*---------------------------------------------------------------------------
*/
+/* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and
+ * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */
+#define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */
+#define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */
+
void
TclInitEncodingSubsystem(void)
{
@@ -545,7 +537,7 @@ TclInitEncodingSubsystem(void)
return;
}
- isLe.s = 1;
+ isLe.s = TCL_ENCODING_LE;
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
@@ -556,7 +548,7 @@ TclInitEncodingSubsystem(void)
* properly formed stream.
*/
- type.encodingName = "identity";
+ type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
@@ -565,21 +557,63 @@ TclInitEncodingSubsystem(void)
tclIdentityEncoding = Tcl_CreateEncoding(&type);
type.encodingName = "utf-8";
- type.toUtfProc = UtfExtToUtfIntProc;
- type.fromUtfProc = UtfIntToUtfExtProc;
+ type.toUtfProc = UtfToUtfProc;
+ type.fromUtfProc = UtfToUtfProc;
type.freeProc = NULL;
type.nullSize = 1;
- type.clientData = NULL;
+ type.clientData = INT2PTR(TCL_ENCODING_UTF);
+ Tcl_CreateEncoding(&type);
+ type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN);
+ type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
- type.encodingName = "unicode";
- type.toUtfProc = UnicodeToUtfProc;
- type.fromUtfProc = UtfToUnicodeProc;
+ type.toUtfProc = Utf16ToUtfProc;
+ type.fromUtfProc = UtfToUcs2Proc;
type.freeProc = NULL;
type.nullSize = 2;
+ type.encodingName = "ucs-2le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE|TCL_ENCODING_NOCOMPLAIN);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2be";
+ type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2";
+ type.clientData = INT2PTR(isLe.c|TCL_ENCODING_NOCOMPLAIN);
+ Tcl_CreateEncoding(&type);
+
+ type.toUtfProc = Utf32ToUtfProc;
+ type.fromUtfProc = UtfToUtf32Proc;
+ type.freeProc = NULL;
+ type.nullSize = 4;
+ type.encodingName = "utf-32le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-32be";
+ type.clientData = INT2PTR(0);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-32";
+ type.clientData = INT2PTR(isLe.c);
+ Tcl_CreateEncoding(&type);
+
+ type.toUtfProc = Utf16ToUtfProc;
+ type.fromUtfProc = UtfToUtf16Proc;
+ type.freeProc = NULL;
+ type.nullSize = 2;
+ type.encodingName = "utf-16le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16be";
+ type.clientData = INT2PTR(0);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16";
type.clientData = INT2PTR(isLe.c);
Tcl_CreateEncoding(&type);
+#ifndef TCL_NO_DEPRECATED
+ type.encodingName = "unicode";
+ Tcl_CreateEncoding(&type);
+#endif
+
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
@@ -686,13 +720,14 @@ TclFinalizeEncodingSubsystem(void)
*-------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
int numDirs;
Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath();
- TclListObjLength(NULL, searchPath, &numDirs);
+ TclListObjLengthM(NULL, searchPath, &numDirs);
if (numDirs == 0) {
return NULL;
}
@@ -729,6 +764,7 @@ Tcl_SetDefaultEncodingDir(
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
+#endif
/*
*-------------------------------------------------------------------------
@@ -834,9 +870,6 @@ FreeEncoding(
if (encodingPtr == NULL) {
return;
}
- if (encodingPtr->refCount<=0) {
- Tcl_Panic("FreeEncoding: refcount problem !!!");
- }
if (encodingPtr->refCount-- <= 1) {
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
@@ -856,7 +889,7 @@ FreeEncoding(
*
* Tcl_GetEncodingName --
*
- * Given an encoding, return the name that was used to constuct the
+ * Given an encoding, return the name that was used to construct the
* encoding.
*
* Results:
@@ -951,6 +984,33 @@ Tcl_GetEncodingNames(
}
/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetEncodingNulLength --
+ *
+ * Given an encoding, return the number of nul bytes used for the
+ * string termination.
+ *
+ * Results:
+ * The number of nul bytes used for the string termination.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+int
+Tcl_GetEncodingNulLength(
+ Tcl_Encoding encoding)
+{
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+
+ return ((Encoding *) encoding)->nullSize;
+}
+
+/*
*------------------------------------------------------------------------
*
* Tcl_SetSystemEncoding --
@@ -1035,9 +1095,26 @@ Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
+ Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
+ encodingPtr->name = NULL;
+ encodingPtr->toUtfProc = typePtr->toUtfProc;
+ encodingPtr->fromUtfProc = typePtr->fromUtfProc;
+ encodingPtr->freeProc = typePtr->freeProc;
+ encodingPtr->nullSize = typePtr->nullSize;
+ encodingPtr->clientData = typePtr->clientData;
+ if (typePtr->nullSize == 2) {
+ encodingPtr->lengthProc = (LengthProc *) unilen;
+ } else if (typePtr->nullSize == 4) {
+ encodingPtr->lengthProc = (LengthProc *) unilen4;
+ } else {
+ encodingPtr->lengthProc = (LengthProc *) strlen;
+ }
+ encodingPtr->refCount = 1;
+ encodingPtr->hPtr = NULL;
+
+ if (typePtr->encodingName) {
Tcl_HashEntry *hPtr;
int isNew;
- Encoding *encodingPtr;
char *name;
Tcl_MutexLock(&encodingMutex);
@@ -1048,30 +1125,17 @@ Tcl_CreateEncoding(
* reference goes away.
*/
- encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
- encodingPtr->hPtr = NULL;
+ Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr);
+ replaceMe->hPtr = NULL;
}
name = (char *)ckalloc(strlen(typePtr->encodingName) + 1);
-
- encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
encodingPtr->name = strcpy(name, typePtr->encodingName);
- encodingPtr->toUtfProc = typePtr->toUtfProc;
- encodingPtr->fromUtfProc = typePtr->fromUtfProc;
- encodingPtr->freeProc = typePtr->freeProc;
- encodingPtr->nullSize = typePtr->nullSize;
- encodingPtr->clientData = typePtr->clientData;
- if (typePtr->nullSize == 1) {
- encodingPtr->lengthProc = (LengthProc *) strlen;
- } else {
- encodingPtr->lengthProc = (LengthProc *) unilen;
- }
- encodingPtr->refCount = 1;
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
-
+ }
return (Tcl_Encoding) encodingPtr;
}
@@ -1106,10 +1170,56 @@ Tcl_ExternalToUtfDString(
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+ Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr);
+ return Tcl_DStringValue(dstPtr);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_ExternalToUtfDStringEx --
+ *
+ * Convert a source buffer from the specified encoding into UTF-8.
+* The parameter flags controls the behavior, if any of the bytes in
+ * the source buffer are invalid or cannot be represented in utf-8.
+ * Possible flags values:
+ * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but
+ * return the first error position (Default in Tcl 9.0).
+ * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default
+ * fallback character. Always return -1 (Default in Tcl 8.7).
+ * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00.
+ * Only valid for "utf-8" and "cesu-8". This flag may be used together
+ * with the other flags.
+ *
+ * Results:
+ * The converted bytes are stored in the DString, which is then NULL
+ * terminated in an encoding-specific manner. The return value is
+ * the error position in the source string or -1 if no conversion error
+ * is reported.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_ExternalToUtfDStringEx(
+ Tcl_Encoding encoding, /* The encoding for the source string, or NULL
+ * for the default system encoding. */
+ const char *src, /* Source string in specified encoding. */
+ int srcLen, /* Source string length in bytes, or < 0 for
+ * encoding-specific string length. */
+ int flags, /* Conversion control flags. */
+ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
+ * converted string is stored. */
+{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
- int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ int dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ const char *srcStart = src;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
@@ -1126,20 +1236,22 @@ Tcl_ExternalToUtfDString(
srcLen = encodingPtr->lengthProc(src);
}
- flags = TCL_ENCODING_START | TCL_ENCODING_END;
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
+ if (encodingPtr->toUtfProc == UtfToUtfProc) {
+ flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF;
+ }
while (1) {
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ src += srcRead;
if (result != TCL_CONVERT_NOSPACE) {
Tcl_DStringSetLength(dstPtr, soFar);
- return Tcl_DStringValue(dstPtr);
+ return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart);
}
-
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -1170,7 +1282,7 @@ Tcl_ExternalToUtfDString(
int
Tcl_ExternalToUtf(
- Tcl_Interp *interp, /* Interp for error return, if not NULL. */
+ TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
@@ -1235,13 +1347,16 @@ Tcl_ExternalToUtf(
if (!noTerminate) {
/*
* If there are any null characters in the middle of the buffer,
- * they will converted to the UTF-8 null character (\xC080). To get
+ * they will converted to the UTF-8 null character (\xC0\x80). To get
* the actual \0 at the end of the destination buffer, we need to
* append it manually. First make room for it...
*/
dstLen--;
}
+ if (encodingPtr->toUtfProc == UtfToUtfProc) {
+ flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF;
+ }
do {
Tcl_EncodingState savedState = *statePtr;
@@ -1251,7 +1366,7 @@ Tcl_ExternalToUtf(
if (*dstCharsPtr <= maxChars) {
break;
}
- dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1);
+ dstLen = TclUtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1);
*statePtr = savedState;
} while (1);
if (!noTerminate) {
@@ -1293,10 +1408,57 @@ Tcl_UtfToExternalDString(
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+ Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr);
+ return Tcl_DStringValue(dstPtr);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_UtfToExternalDStringEx --
+ *
+ * Convert a source buffer from UTF-8 to the specified encoding.
+ * The parameter flags controls the behavior, if any of the bytes in
+ * the source buffer are invalid or cannot be represented in the
+ * target encoding.
+ * Possible flags values:
+ * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but
+ * return the first error position (Default in Tcl 9.0).
+ * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default
+ * fallback character. Always return -1 (Default in Tcl 8.7).
+ * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00.
+ * Only valid for "utf-8" and "cesu-8". This flag may be used together
+ * with the other flags.
+ *
+ * Results:
+ * The converted bytes are stored in the DString, which is then NULL
+ * terminated in an encoding-specific manner. The return value is
+ * the error position in the source string or -1 if no conversion error
+ * is reported.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToExternalDStringEx(
+ Tcl_Encoding encoding, /* The encoding for the converted string, or
+ * NULL for the default system encoding. */
+ const char *src, /* Source string in UTF-8. */
+ int srcLen, /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ int flags, /* Conversion control flags. */
+ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
+ * converted string is stored. */
+{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
- int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ int dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ const char *srcStart = src;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
@@ -1312,23 +1474,23 @@ Tcl_UtfToExternalDString(
} else if (srcLen < 0) {
srcLen = strlen(src);
}
- flags = TCL_ENCODING_START | TCL_ENCODING_END;
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
- srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
- &dstChars);
+ srcLen, flags, &state, dst, dstLen,
+ &srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ src += srcRead;
if (result != TCL_CONVERT_NOSPACE) {
- if (encodingPtr->nullSize == 2) {
- Tcl_DStringSetLength(dstPtr, soFar + 1);
+ int i = soFar + encodingPtr->nullSize - 1;
+ while (i >= soFar) {
+ Tcl_DStringSetLength(dstPtr, i--);
}
- Tcl_DStringSetLength(dstPtr, soFar);
- return Tcl_DStringValue(dstPtr);
+ return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart);
}
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -1359,7 +1521,7 @@ Tcl_UtfToExternalDString(
int
Tcl_UtfToExternal(
- Tcl_Interp *interp, /* Interp for error return, if not NULL. */
+ TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
@@ -1417,12 +1579,9 @@ Tcl_UtfToExternal(
dstLen -= encodingPtr->nullSize;
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen,
- flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
- dstCharsPtr);
- if (encodingPtr->nullSize == 2) {
- dst[*dstWrotePtr + 1] = '\0';
- }
- dst[*dstWrotePtr] = '\0';
+ flags, statePtr, dst, dstLen, srcReadPtr,
+ dstWrotePtr, dstCharsPtr);
+ memset(&dst[*dstWrotePtr], '\0', encodingPtr->nullSize);
return result;
}
@@ -1445,14 +1604,15 @@ Tcl_UtfToExternal(
*---------------------------------------------------------------------------
*/
#undef Tcl_FindExecutable
-void
+const char *
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
- TclInitSubsystems();
+ const char *version = Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
+ return version;
}
/*
@@ -1488,7 +1648,7 @@ OpenEncodingFileChannel(
Tcl_Channel chan = NULL;
int i, numDirs;
- TclListObjGetElements(NULL, searchPath, &numDirs, &dir);
+ TclListObjGetElementsM(NULL, searchPath, &numDirs, &dir);
Tcl_IncrRefCount(nameObj);
Tcl_AppendToObj(fileNameObj, ".enc", -1);
Tcl_IncrRefCount(fileNameObj);
@@ -1709,7 +1869,7 @@ LoadTableEncoding(
};
Tcl_DStringInit(&lineString);
- if (Tcl_Gets(chan, &lineString) == -1) {
+ if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
return NULL;
}
line = Tcl_DStringValue(&lineString);
@@ -1835,8 +1995,8 @@ LoadTableEncoding(
*/
if (dataPtr->fromUnicode[0] != NULL) {
- if (dataPtr->fromUnicode[0]['\\'] == '\0') {
- dataPtr->fromUnicode[0]['\\'] = '\\';
+ if (dataPtr->fromUnicode[0][(int)'\\'] == '\0') {
+ dataPtr->fromUnicode[0][(int)'\\'] = '\\';
}
}
}
@@ -2039,7 +2199,7 @@ LoadEscapeEncoding(
Tcl_DStringFree(&lineString);
}
- size = TclOffset(EscapeEncodingData, subTables)
+ size = offsetof(EscapeEncodingData, subTables)
+ Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *)ckalloc(size);
dataPtr->initLen = strlen(init);
@@ -2097,15 +2257,11 @@ LoadEscapeEncoding(
static int
BinaryProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
const char *src, /* Source string (unknown encoding). */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2144,11 +2300,11 @@ BinaryProc(
/*
*-------------------------------------------------------------------------
*
- * UtfIntToUtfExtProc --
+ * UtfToUtfProc --
*
- * Convert from UTF-8 to UTF-8. While converting null-bytes from the
- * Tcl's internal representation (0xC0, 0x80) to the official
- * representation (0x00). See UtfToUtfProc for details.
+ * Converts from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
+ * is not a no-op, because it turns a stream of improperly formed
+ * UTF-8 into a properly-formed stream.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2159,19 +2315,21 @@ BinaryProc(
*-------------------------------------------------------------------------
*/
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+# define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR))
+#else
+# define STOPONERROR (flags & TCL_ENCODING_STOPONERROR)
+#endif
+
static int
-UtfIntToUtfExtProc(
- ClientData clientData, /* Not used. */
+UtfToUtfProc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
- char *dst, /* Output buffer in which converted string
- * is stored. */
+ TCL_UNUSED(Tcl_EncodingState *),
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
@@ -2186,18 +2344,157 @@ UtfIntToUtfExtProc(
* correspond to the bytes stored in the
* output buffer. */
{
- return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
-}
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd;
+ int result, numChars, charLimit = INT_MAX;
+ int ch;
+
+ result = TCL_OK;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= 6;
+ }
+ if (flags & TCL_ENCODING_CHAR_LIMIT) {
+ charLimit = *dstCharsPtr;
+ }
+
+ dstStart = dst;
+ flags |= PTR2INT(clientData);
+ dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6);
+
+ for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & TCL_ENCODING_MODIFIED))) {
+ /*
+ * Copy 7bit characters, but skip null-bytes when we are in input
+ * mode, so that they get converted to 0xC080.
+ */
+ *dst++ = *src++;
+ } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd)
+ && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) {
+ /*
+ * If in input mode, and -strict or -failindex is specified: This is an error.
+ */
+ if (flags & TCL_ENCODING_MODIFIED) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+
+ /*
+ * Convert 0xC080 to real nulls when we are in output mode, with or without '-strict'.
+ */
+ *dst++ = 0;
+ src += 2;
+ } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
+ /*
+ * Always check before using TclUtfToUCS4. Not doing can so
+ * cause it run beyond the end of the buffer! If we happen such an
+ * incomplete char its bytes are made to represent themselves
+ * unless the user has explicitly asked to be told.
+ */
+
+ if (flags & TCL_ENCODING_MODIFIED) {
+ if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) {
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ ch = UCHAR(*src++);
+ } else {
+ char chbuf[2];
+ chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
+ TclUtfToUCS4(chbuf, &ch);
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ } else {
+ int low;
+ const char *saveSrc = src;
+ size_t len = TclUtfToUCS4(src, &ch);
+ if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED)
+ && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ src += len;
+ if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) {
+ if (ch > 0xFFFF) {
+ /* CESU-8 6-byte sequence for chars > U+FFFF */
+ ch -= 0x10000;
+ *dst++ = 0xED;
+ *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0);
+ *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
+ ch = (ch & 0x0CFF) | 0xDC00;
+ }
+ goto cesu8;
+ } else if ((ch | 0x7FF) == 0xDFFF) {
+ /*
+ * A surrogate character is detected, handle especially.
+ */
+
+ low = ch;
+ len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
+
+ if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) {
+
+ if (STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ }
+ cesu8:
+ *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF);
+ *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF);
+ *dst++ = (char) ((ch | 0x80) & 0xBF);
+ continue;
+ }
+ src += len;
+ dst += Tcl_UniCharToUtf(ch, dst);
+ ch = low;
+ } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && (((ch & ~0x7FF) == 0xD800))) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)
+ && (flags & TCL_ENCODING_MODIFIED) && ((ch & ~0x7FF) == 0xD800)) {
+ result = TCL_CONVERT_SYNTAX;
+ src = saveSrc;
+ break;
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
/*
*-------------------------------------------------------------------------
*
- * UtfExtToUtfIntProc --
+ * Utf32ToUtfProc --
*
- * Convert from UTF-8 to UTF-8 while converting null-bytes from the
- * official representation (0x00) to Tcl's internal representation (0xC0,
- * 0x80). See UtfToUtfProc for details.
+ * Convert from UTF-32 to UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2209,16 +2506,12 @@ UtfIntToUtfExtProc(
*/
static int
-UtfExtToUtfIntProc(
- ClientData clientData, /* Not used. */
- const char *src, /* Source string in UTF-8. */
+Utf32ToUtfProc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
+ const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2235,18 +2528,76 @@ UtfExtToUtfIntProc(
* correspond to the bytes stored in the
* output buffer. */
{
- return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
-}
+ const char *srcStart, *srcEnd;
+ const char *dstEnd, *dstStart;
+ int result, numChars, charLimit = INT_MAX;
+ int ch;
+
+ flags |= PTR2INT(clientData);
+ if (flags & TCL_ENCODING_CHAR_LIMIT) {
+ charLimit = *dstCharsPtr;
+ }
+ result = TCL_OK;
+ /*
+ * Check alignment with utf-32 (4 == sizeof(UTF-32))
+ */
+
+ if ((srcLen % 4) != 0) {
+ result = TCL_CONVERT_MULTIBYTE;
+ srcLen &= -4;
+ }
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+
+ if (flags & TCL_ENCODING_LE) {
+ ch = (src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
+ } else {
+ ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF);
+ }
+ if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)
+ && ((ch & ~0x7FF) == 0xD800))) {
+ if (STOPONERROR) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ }
+
+ /*
+ * Special case for 1-byte utf chars for speed. Make sure we work with
+ * unsigned short-size data.
+ */
+
+ if ((ch > 0) && (ch < 0x80)) {
+ *dst++ = (ch & 0xFF);
+ } else {
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+ src += sizeof(unsigned int);
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
/*
*-------------------------------------------------------------------------
*
- * UtfToUtfProc --
+ * UtfToUtf32Proc --
*
- * Converts from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
- * is not a no-op, because it turns a stream of improperly formed
- * UTF-8 into a properly-formed stream.
+ * Convert from UTF-8 to UTF-32.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2258,16 +2609,12 @@ UtfExtToUtfIntProc(
*/
static int
-UtfToUtfProc(
- ClientData clientData, /* Not used. */
+UtfToUtf32Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2280,37 +2627,27 @@ UtfToUtfProc(
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
- int *dstCharsPtr, /* Filled with the number of characters that
+ int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
- int pureNullMode) /* Convert embedded nulls from internal
- * representation to real null-bytes or vice
- * versa. Also combine or separate surrogate pairs */
{
- const char *srcStart, *srcEnd, *srcClose;
- const char *dstStart, *dstEnd;
- int result, numChars, charLimit = INT_MAX;
- Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
-
- if (flags & TCL_ENCODING_START) {
- *statePtr = 0;
- }
- result = TCL_OK;
+ const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
+ int result, numChars;
+ int ch, len;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
- srcClose -= 6;
- }
- if (flags & TCL_ENCODING_CHAR_LIMIT) {
- charLimit = *dstCharsPtr;
+ srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
- dstEnd = dst + dstLen - ((pureNullMode == 1) ? 4 : TCL_UTF_MAX);
+ dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+ flags |= PTR2INT(clientData);
- for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
@@ -2324,77 +2661,24 @@ UtfToUtfProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (pureNullMode == 0))) {
- /*
- * Copy 7bit characters, but skip null-bytes when we are in input
- * mode, so that they get converted to 0xC080.
- */
-
- *dst++ = *src++;
- *chPtr = 0; /* reset surrogate handling */
- } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd)
- && (UCHAR(src[1]) == 0x80) && (pureNullMode == 1)) {
- /*
- * Convert 0xC080 to real nulls when we are in output mode.
- */
-
- *dst++ = 0;
- *chPtr = 0; /* reset surrogate handling */
- src += 2;
- } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
- /*
- * Always check before using TclUtfToUniChar. Not doing can so
- * cause it run beyond the end of the buffer! If we happen such an
- * incomplete char its bytes are made to represent themselves
- * unless the user has explicitly asked to be told.
- */
-
- if ((flags & TCL_ENCODING_STOPONERROR) && (pureNullMode == 0)) {
- result = TCL_CONVERT_MULTIBYTE;
+ len = TclUtfToUCS4(src, &ch);
+ if ((ch & ~0x7FF) == 0xD800) {
+ if (STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
break;
}
- *chPtr = UCHAR(*src);
- src += 1;
- dst += Tcl_UniCharToUtf(*chPtr, dst);
+ }
+ src += len;
+ if (flags & TCL_ENCODING_LE) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = ((ch >> 8) & 0xFF);
+ *dst++ = ((ch >> 16) & 0xFF);
+ *dst++ = ((ch >> 24) & 0xFF);
} else {
- size_t len = TclUtfToUniChar(src, chPtr);
- if ((len < 2) && (*chPtr != 0) && (flags & TCL_ENCODING_STOPONERROR)
- && ((*chPtr & ~0x7FF) != 0xD800) && (pureNullMode == 0)) {
- result = TCL_CONVERT_SYNTAX;
- break;
- }
- src += len;
- if ((*chPtr & ~0x7FF) == 0xD800) {
- Tcl_UniChar low;
- /* A surrogate character is detected, handle especially */
-#if TCL_UTF_MAX <= 4
- if ((len < 3) && ((src[3 - len] & 0xC0) != 0x80)) {
- /* It's invalid. See [ed29806ba] */
- *chPtr = UCHAR(src[-1]);
- dst += Tcl_UniCharToUtf(*chPtr, dst);
- continue;
- }
-#endif
- low = *chPtr;
- len = (src <= srcEnd-3) ? Tcl_UtfToUniChar(src, &low) : 0;
- if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) {
- *dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
- *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
- *dst++ = (char) ((*chPtr | 0x80) & 0xBF);
- *chPtr = 0; /* reset surrogate handling */
- continue;
- } else if ((TCL_UTF_MAX > 3) || (pureNullMode == 1)) {
- int full = (((*chPtr & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000;
- *dst++ = (char) (((full >> 18) | 0xF0) & 0xF7);
- *dst++ = (char) (((full >> 12) | 0x80) & 0xBF);
- *dst++ = (char) (((full >> 6) | 0x80) & 0xBF);
- *dst++ = (char) ((full | 0x80) & 0xBF);
- *chPtr = 0; /* reset surrogate handling */
- src += len;
- continue;
- }
- }
- dst += Tcl_UniCharToUtf(*chPtr, dst);
+ *dst++ = ((ch >> 24) & 0xFF);
+ *dst++ = ((ch >> 16) & 0xFF);
+ *dst++ = ((ch >> 8) & 0xFF);
+ *dst++ = (ch & 0xFF);
}
}
@@ -2407,7 +2691,7 @@ UtfToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UnicodeToUtfProc --
+ * Utf16ToUtfProc --
*
* Convert from UTF-16 to UTF-8.
*
@@ -2421,16 +2705,12 @@ UtfToUtfProc(
*/
static int
-UnicodeToUtfProc(
- ClientData clientData, /* != NULL means LE, == NUL means BE */
+Utf16ToUtfProc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2452,12 +2732,16 @@ UnicodeToUtfProc(
int result, numChars, charLimit = INT_MAX;
unsigned short ch;
+ flags |= PTR2INT(clientData);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
- /* check alignment with utf-16 (2 == sizeof(UTF-16)) */
+ /*
+ * Check alignment with utf-16 (2 == sizeof(UTF-16))
+ */
+
if ((srcLen % 2) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen--;
@@ -2468,7 +2752,7 @@ UnicodeToUtfProc(
*/
if ((srcLen >= 2) &&
- ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) {
+ ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
@@ -2485,7 +2769,7 @@ UnicodeToUtfProc(
break;
}
- if (clientData) {
+ if (flags & TCL_ENCODING_LE) {
ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
@@ -2513,7 +2797,7 @@ UnicodeToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UtfToUnicodeProc --
+ * UtfToUtf16Proc --
*
* Convert from UTF-8 to UTF-16.
*
@@ -2527,16 +2811,12 @@ UnicodeToUtfProc(
*/
static int
-UtfToUnicodeProc(
- ClientData clientData, /* != NULL means LE, == NUL means BE */
+UtfToUtf16Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2555,11 +2835,8 @@ UtfToUnicodeProc(
{
const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
- Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
+ int ch, len;
- if (flags & TCL_ENCODING_START) {
- *statePtr = 0;
- }
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
@@ -2569,6 +2846,7 @@ UtfToUnicodeProc(
dstStart = dst;
dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+ flags |= PTR2INT(clientData);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
@@ -2585,38 +2863,138 @@ UtfToUnicodeProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- src += TclUtfToUniChar(src, chPtr);
-
- if (clientData) {
-#if TCL_UTF_MAX > 4
- if (*chPtr <= 0xFFFF) {
- *dst++ = (*chPtr & 0xFF);
- *dst++ = (*chPtr >> 8);
+ len = TclUtfToUCS4(src, &ch);
+ if ((ch & ~0x7FF) == 0xD800) {
+ if (STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ }
+ src += len;
+ if (flags & TCL_ENCODING_LE) {
+ if (ch <= 0xFFFF) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = (ch >> 8);
} else {
- *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
- *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
- *dst++ = (*chPtr & 0xFF);
- *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
+ *dst++ = (((ch - 0x10000) >> 10) & 0xFF);
+ *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
+ *dst++ = (ch & 0xFF);
+ *dst++ = ((ch >> 8) & 0x3) | 0xDC;
}
-#else
- *dst++ = (*chPtr & 0xFF);
- *dst++ = (*chPtr >> 8);
-#endif
} else {
-#if TCL_UTF_MAX > 4
- if (*chPtr <= 0xFFFF) {
- *dst++ = (*chPtr >> 8);
- *dst++ = (*chPtr & 0xFF);
+ if (ch <= 0xFFFF) {
+ *dst++ = (ch >> 8);
+ *dst++ = (ch & 0xFF);
} else {
- *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
- *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
- *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
- *dst++ = (*chPtr & 0xFF);
+ *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
+ *dst++ = (((ch - 0x10000) >> 10) & 0xFF);
+ *dst++ = ((ch >> 8) & 0x3) | 0xDC;
+ *dst++ = (ch & 0xFF);
}
+ }
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * UtfToUcs2Proc --
+ *
+ * Convert from UTF-8 to UCS-2.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UtfToUcs2Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
+ const char *src, /* Source string in UTF-8. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ TCL_UNUSED(Tcl_EncodingState *),
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
+ int dstLen, /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr, /* Filled with the number of bytes from the
+ * source string that were converted. This may
+ * be less than the original source length if
+ * there was a problem converting some source
+ * characters. */
+ int *dstWrotePtr, /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr) /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
+ int result, numChars;
+#if TCL_UTF_MAX < 4
+ int len;
+#endif
+ Tcl_UniChar ch = 0;
+
+ flags |= PTR2INT(clientData);
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+#if TCL_UTF_MAX < 4
+ src += (len = TclUtfToUniChar(src, &ch));
+ if ((ch >= 0xD800) && (len < 3)) {
+ src += TclUtfToUniChar(src, &ch);
+ ch = 0xFFFD;
+ }
#else
- *dst++ = (*chPtr >> 8);
- *dst++ = (*chPtr & 0xFF);
+ src += TclUtfToUniChar(src, &ch);
+ if (ch > 0xFFFF) {
+ ch = 0xFFFD;
+ }
#endif
+
+ /*
+ * Need to handle this in a way that won't cause misalignment by
+ * casting dst to a Tcl_UniChar. [Bug 1122671]
+ */
+
+ if (flags & TCL_ENCODING_LE) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = (ch >> 8);
+ } else {
+ *dst++ = (ch >> 8);
+ *dst++ = (ch & 0xFF);
}
}
*srcReadPtr = src - srcStart;
@@ -2644,16 +3022,12 @@ UtfToUnicodeProc(
static int
TableToUtfProc(
- ClientData clientData, /* TableEncodingData that specifies
+ void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2710,7 +3084,7 @@ TableToUtfProc(
ch = pageZero[byte];
}
if ((ch == 0) && (byte != 0)) {
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (STOPONERROR) {
result = TCL_CONVERT_SYNTAX;
break;
}
@@ -2757,16 +3131,12 @@ TableToUtfProc(
static int
TableFromUtfProc(
- ClientData clientData, /* TableEncodingData that specifies
+ void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2817,12 +3187,12 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
/* Unicode chars > +U0FFFF cannot be represented in any table encoding */
if (ch & 0xFFFF0000) {
word = 0;
} else
-#elif TCL_UTF_MAX == 4
+#else
if (!len) {
word = 0;
} else
@@ -2830,7 +3200,7 @@ TableFromUtfProc(
word = fromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
@@ -2879,15 +3249,11 @@ TableFromUtfProc(
static int
Iso88591ToUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2963,15 +3329,11 @@ Iso88591ToUtfProc(
static int
Iso88591FromUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -3022,15 +3384,15 @@ Iso88591FromUtfProc(
*/
if (ch > 0xFF
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (len < 3)) {
len = 4;
}
@@ -3075,10 +3437,10 @@ Iso88591FromUtfProc(
static void
TableFreeProc(
- ClientData clientData) /* TableEncodingData that specifies
+ void *clientData) /* TableEncodingData that specifies
* encoding. */
{
- TableEncodingData *dataPtr = (TableEncodingData *) clientData;
+ TableEncodingData *dataPtr = (TableEncodingData *)clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
@@ -3110,7 +3472,7 @@ TableFreeProc(
static int
EscapeToUtfProc(
- ClientData clientData, /* EscapeEncodingData that specifies
+ void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
@@ -3136,7 +3498,7 @@ EscapeToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData;
+ EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd;
const unsigned short *const *tableToUnicode;
const Encoding *encodingPtr;
@@ -3253,7 +3615,7 @@ EscapeToUtfProc(
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
- if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
+ if (!STOPONERROR) {
/*
* Skip the unknown escape sequence.
*/
@@ -3324,7 +3686,7 @@ EscapeToUtfProc(
static int
EscapeFromUtfProc(
- ClientData clientData, /* EscapeEncodingData that specifies
+ void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
@@ -3428,7 +3790,7 @@ EscapeFromUtfProc(
if (word == 0) {
state = oldState;
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
@@ -3536,7 +3898,7 @@ EscapeFromUtfProc(
static void
EscapeFreeProc(
- ClientData clientData) /* EscapeEncodingData that specifies
+ void *clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
@@ -3613,7 +3975,7 @@ GetTableEncoding(
/*
*---------------------------------------------------------------------------
*
- * unilen --
+ * unilen, unilen4 --
*
* A helper function for the Tcl_ExternalToUtf functions. This function
* is similar to strlen for double-byte characters: it returns the number
@@ -3640,6 +4002,19 @@ unilen(
}
return (char *) p - src;
}
+
+static size_t
+unilen4(
+ const char *src)
+{
+ unsigned int *p;
+
+ p = (unsigned int *) src;
+ while (*p != 0x00000000) {
+ p++;
+ }
+ return (char *) p - src;
+}
/*
*-------------------------------------------------------------------------
@@ -3667,7 +4042,7 @@ unilen(
static void
InitializeEncodingSearchPath(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
@@ -3680,7 +4055,7 @@ InitializeEncodingSearchPath(
Tcl_IncrRefCount(searchPathObj);
libPathObj = TclGetLibraryPath();
Tcl_IncrRefCount(libPathObj);
- TclListObjLength(NULL, libPathObj, &numDirs);
+ TclListObjLengthM(NULL, libPathObj, &numDirs);
for (i = 0; i < numDirs; i++) {
Tcl_Obj *directoryObj, *pathObj;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 3b80a21..963f1d8 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -4,7 +4,7 @@
* Contains support for ensembles (see TIP#112), which provide simple
* mechanism for creating composite commands on top of namespaces.
*
- * Copyright (c) 2005-2013 Donal K. Fellows.
+ * Copyright © 2005-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,14 +21,12 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
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,
+static int NsEnsembleImplementationCmdNR(void *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 DeleteEnsembleConfig(void *clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
Tcl_Obj *fix);
@@ -72,8 +70,8 @@ enum EnsConfigOpts {
};
/*
- * 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
+ * ensembleCmdType is 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.
*/
@@ -86,9 +84,24 @@ static const Tcl_ObjType ensembleCmdType = {
NULL /* setFromAnyProc */
};
+#define ECRSetInternalRep(objPtr, ecRepPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (ecRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \
+ } while (0)
+
+#define ECRGetInternalRep(objPtr, ecRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \
+ (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
- * The internal rep for caching ensemble subcommand lookups and
- * spell corrections.
+ * The internal rep for caching ensemble subcommand lookups and spelling
+ * corrections.
*/
typedef struct {
@@ -98,10 +111,9 @@ typedef struct {
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
- Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
- * hash table. */
+ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
+ * table. */
} EnsembleCmdRep;
-
static inline Tcl_Obj *
NewNsObj(
@@ -111,9 +123,8 @@ NewNsObj(
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
- } else {
- return Tcl_NewStringObj(nsPtr->fullName, -1);
}
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
}
/*
@@ -140,21 +151,22 @@ NewNsObj(
int
TclNamespaceEnsembleCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
- *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
+ *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
const char *simpleName;
- int index, done;
+ int index;
+ int done;
- if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
+ if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
@@ -176,7 +188,8 @@ TclNamespaceEnsembleCmd(
switch ((enum EnsSubcmds) index) {
case ENS_CREATE: {
const char *name;
- int len, allocatedMapFlag = 0;
+ int len;
+ int allocatedMapFlag = 0;
/*
* Defaults
*/
@@ -221,7 +234,7 @@ TclNamespaceEnsembleCmd(
cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -230,7 +243,7 @@ TclNamespaceEnsembleCmd(
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_PARAM:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -260,7 +273,7 @@ TclNamespaceEnsembleCmd(
Tcl_Obj **listv;
const char *cmd;
- if (TclListObjGetElements(interp, listObj, &len,
+ if (TclListObjGetElementsM(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
@@ -302,7 +315,8 @@ TclNamespaceEnsembleCmd(
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
- Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+ Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+ &done);
} while (!done);
if (allocatedMapFlag) {
@@ -324,7 +338,7 @@ TclNamespaceEnsembleCmd(
}
continue;
case CRT_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -336,8 +350,8 @@ TclNamespaceEnsembleCmd(
}
TclGetNamespaceForQualName(interp, name, cxtPtr,
- TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
- &simpleName);
+ TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
+ &actualCxtPtr, &simpleName);
/*
* Create the ensemble. Note that this might delete another ensemble
@@ -347,8 +361,8 @@ TclNamespaceEnsembleCmd(
*/
token = TclCreateEnsembleInNs(interp, simpleName,
- (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
@@ -486,7 +500,8 @@ TclNamespaceEnsembleCmd(
Tcl_SetObjResult(interp, resultObj);
} else {
- int len, allocatedMapFlag = 0;
+ int len;
+ int 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 */
@@ -519,13 +534,13 @@ TclNamespaceEnsembleCmd(
}
switch ((enum EnsConfigOpts) index) {
case CONF_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(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) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
paramObj = (len > 0 ? objv[1] : NULL);
@@ -547,8 +562,8 @@ TclNamespaceEnsembleCmd(
continue;
}
do {
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
+ if (TclListObjLengthM(interp, listObj, &len
+ ) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -567,6 +582,14 @@ TclNamespaceEnsembleCmd(
}
goto freeMapAndError;
}
+ if (TclListObjGetElementsM(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ 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);
@@ -576,7 +599,8 @@ TclNamespaceEnsembleCmd(
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+ Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
+ &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
@@ -608,7 +632,7 @@ TclNamespaceEnsembleCmd(
}
continue;
case CONF_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
unknownObj = (len > 0 ? objv[1] : NULL);
@@ -650,24 +674,22 @@ TclNamespaceEnsembleCmd(
Tcl_Command
TclCreateEnsembleInNs(
Tcl_Interp *interp,
-
- const char *name, /* Simple name of command to create (no */
- /* namespace components). */
- Tcl_Namespace /* Name of namespace to create the command in. */
- *nameNsPtr,
- Tcl_Namespace
- *ensembleNsPtr, /* Name of the namespace for the ensemble. */
- int flags
- )
+ const char *name, /* Simple name of command to create (no
+ * namespace components). */
+ Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command
+ * in. */
+ Tcl_Namespace *ensembleNsPtr,
+ /* Name of the namespace for the ensemble. */
+ int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
- ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
- (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
- NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+ (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
+ NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
ckfree(ensemblePtr);
return NULL;
@@ -701,18 +723,15 @@ TclCreateEnsembleInNs(
}
return ensemblePtr->token;
-
}
-
-
+
/*
*----------------------------------------------------------------------
*
* Tcl_CreateEnsemble
*
- * Create a simple ensemble attached to the given namespace.
- *
- * Deprecated by TclCreateEnsembleInNs.
+ * Create a simple ensemble attached to the given namespace. Deprecated
+ * (internally) by TclCreateEnsembleInNs.
*
* Value
*
@@ -732,8 +751,8 @@ Tcl_CreateEnsemble(
Tcl_Namespace *namespacePtr,
int flags)
{
- Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
- *actualNsPtr;
+ Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
const char * simpleName;
if (nsPtr == NULL) {
@@ -741,11 +760,10 @@ Tcl_CreateEnsemble(
}
TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
- &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
return TclCreateEnsembleInNs(interp, simpleName,
- (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
-
/*
*----------------------------------------------------------------------
@@ -774,7 +792,7 @@ Tcl_SetEnsembleSubcommandList(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -783,7 +801,7 @@ Tcl_SetEnsembleSubcommandList(
if (subcmdList != NULL) {
int length;
- if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -791,7 +809,7 @@ Tcl_SetEnsembleSubcommandList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
@@ -850,7 +868,7 @@ Tcl_SetEnsembleParameterList(
Tcl_Obj *oldList;
int length;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -859,7 +877,7 @@ Tcl_SetEnsembleParameterList(
if (paramList == NULL) {
length = 0;
} else {
- if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, paramList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -867,7 +885,7 @@ Tcl_SetEnsembleParameterList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
@@ -926,14 +944,15 @@ Tcl_SetEnsembleMappingDict(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
- int size, done;
+ int size;
+ int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
@@ -967,7 +986,7 @@ Tcl_SetEnsembleMappingDict(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
@@ -1025,7 +1044,7 @@ Tcl_SetEnsembleUnknownHandler(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1034,7 +1053,7 @@ Tcl_SetEnsembleUnknownHandler(
if (unknownList != NULL) {
int length;
- if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -1042,7 +1061,7 @@ Tcl_SetEnsembleUnknownHandler(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
@@ -1091,14 +1110,14 @@ Tcl_SetEnsembleFlags(
EnsembleConfig *ensemblePtr;
int wasCompiled;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
/*
@@ -1167,7 +1186,7 @@ Tcl_GetEnsembleSubcommandList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1176,7 +1195,7 @@ Tcl_GetEnsembleSubcommandList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
@@ -1209,7 +1228,7 @@ Tcl_GetEnsembleParameterList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1218,7 +1237,7 @@ Tcl_GetEnsembleParameterList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
@@ -1251,7 +1270,7 @@ Tcl_GetEnsembleMappingDict(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1260,7 +1279,7 @@ Tcl_GetEnsembleMappingDict(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
@@ -1292,7 +1311,7 @@ Tcl_GetEnsembleUnknownHandler(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1301,7 +1320,7 @@ Tcl_GetEnsembleUnknownHandler(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
@@ -1333,7 +1352,7 @@ Tcl_GetEnsembleFlags(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1342,7 +1361,7 @@ Tcl_GetEnsembleFlags(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
@@ -1374,7 +1393,7 @@ Tcl_GetEnsembleNamespace(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1383,7 +1402,7 @@ Tcl_GetEnsembleNamespace(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
@@ -1424,7 +1443,7 @@ Tcl_FindEnsemble(
return NULL;
}
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link chains
* rather than duplicating it.
@@ -1432,7 +1451,8 @@ Tcl_FindEnsemble(
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (cmdPtr == NULL
+ || cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
@@ -1470,11 +1490,11 @@ Tcl_IsEnsemble(
{
Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
return 0;
}
return 1;
@@ -1515,7 +1535,8 @@ TclMakeEnsemble(
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
- int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
+ int i, nameCount = 0;
+ int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
@@ -1637,7 +1658,7 @@ TclMakeEnsemble(
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
- ckfree((char *) nameParts);
+ ckfree(nameParts);
}
return ensemble;
}
@@ -1645,7 +1666,7 @@ TclMakeEnsemble(
/*
*----------------------------------------------------------------------
*
- * NsEnsembleImplementationCmd --
+ * TclEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
* namespace other than the global namespace) as a command with the same
@@ -1664,9 +1685,9 @@ TclMakeEnsemble(
*----------------------------------------------------------------------
*/
-static int
-NsEnsembleImplementationCmd(
- ClientData clientData,
+int
+TclEnsembleImplementationCmd(
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1677,12 +1698,12 @@ NsEnsembleImplementationCmd(
static int
NsEnsembleImplementationCmdNR(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- EnsembleConfig *ensemblePtr = clientData;
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
/* The ensemble itself. */
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
@@ -1696,7 +1717,7 @@ NsEnsembleImplementationCmdNR(
int subIdx;
/*
- * Must recheck objc, since numParameters might have changed. Cf. test
+ * Must recheck objc since numParameters might have changed. See test
* namespace-53.9.
*/
@@ -1704,7 +1725,7 @@ NsEnsembleImplementationCmdNR(
subIdx = 1 + ensemblePtr->numParameters;
if (objc < subIdx + 1) {
/*
- * We don't have a subcommand argument. Make error message.
+ * No subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
@@ -1722,7 +1743,7 @@ NsEnsembleImplementationCmdNR(
return TCL_ERROR;
}
- if (ensemblePtr->nsPtr->flags & NS_DYING) {
+ if (ensemblePtr->nsPtr->flags & NS_DEAD) {
/*
* Don't know how we got here, but make things give up quickly.
*/
@@ -1736,26 +1757,24 @@ NsEnsembleImplementationCmdNR(
}
/*
- * Determine if the table of subcommands is right. If so, we can just look
- * up in there and go straight to dispatch.
+ * If the table of subcommands is valid just lookup up the command there
+ * and go to dispatch.
*/
subObj = objv[subIdx];
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.
+ * Table of subcommands is still valid so if the internal representtion
+ * is an ensembleCmd, just call it.
*/
+ EnsembleCmdRep *ensembleCmd;
- if (subObj->typePtr==&ensembleCmdType){
- EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
-
+ ECRGetInternalRep(subObj, ensembleCmd);
+ if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
- prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
+ prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
@@ -1769,8 +1788,8 @@ NsEnsembleImplementationCmdNR(
}
/*
- * Look in the hashtable for the subcommand name; this is the fastest way
- * of all if there is no cache in operation.
+ * Look in the hashtable for the named subcommand. This is the fastest
+ * path if there is no cache in operation.
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
@@ -1778,44 +1797,43 @@ NsEnsembleImplementationCmdNR(
if (hPtr != NULL) {
/*
- * Cache for later in the subcommand object.
+ * Cache ensemble in the subcommand object for later.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
- * Could not map, no prefixing, go to unknown/error handling.
+ * 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.
+ * If the command isn't yet confirmed with the hash as part of building
+ * the export table, 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). */
+ const char *subcmdName; /* Name of the subcommand or unique prefix of
+ * it (a non-unique prefix produces an error).
+ */
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
- subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
+ subcmdName = TclGetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
- (unsigned) stringLength);
+ 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.
+ * Hash search filters out the exact-match case, so getting
+ * here indicates that the subcommand is an ambiguous
+ * prefix of at least two exported subcommands, which is an
+ * error case.
*/
goto unknownOrAmbiguousSubcommand;
@@ -1823,9 +1841,8 @@ NsEnsembleImplementationCmdNR(
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.
+ * The table is sorted so stop searching because a match would
+ * have been found already.
*/
break;
@@ -1833,7 +1850,7 @@ NsEnsembleImplementationCmdNR(
}
if (fullName == NULL) {
/*
- * The subcommand is not a prefix of anything, so bail out!
+ * The subcommand is not a prefix of anything. Bail out!
*/
goto unknownOrAmbiguousSubcommand;
@@ -1858,31 +1875,29 @@ NsEnsembleImplementationCmdNR(
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
- prefixObj = Tcl_GetHashValue(hPtr);
+ prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
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,
+ * Execute the subcommand by populating an array of objects, which might
+ * not be the same length as the number of arguments to this ensemble
+ * command, and then handing it to the main command-lookup engine. In
+ * theory, the command could be looked up right here using 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.)
+ * but don't do that because cacheing of the command object should help.
*/
{
- Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
+ Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
int copyObjc, prefixObjc;
- TclListObjLength(NULL, prefixObj, &prefixObjc);
+ TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
@@ -1900,8 +1915,8 @@ NsEnsembleImplementationCmdNR(
TclDecrRefCount(prefixObj);
/*
- * Record what arguments the script sent in so that things like
- * Tcl_WrongNumArgs can give the correct error message. Parameters
+ * Record the words of the command as given so that routines like
+ * Tcl_WrongNumArgs can produce the correct error message. Parameters
* count both as inserted and removed arguments.
*/
@@ -1916,17 +1931,16 @@ NsEnsembleImplementationCmdNR(
*/
TclSkipTailcall(interp);
- TclListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
+ TclListObjGetElementsM(NULL, copyPtr, &copyObjc, &copyObjv);
((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
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.
+ * The named subcommand did not match any exported command. If there is a
+ * handler registered unknown subcommands, call it, but not more than once
+ * for this call.
*/
if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
@@ -1942,10 +1956,10 @@ NsEnsembleImplementationCmdNR(
}
/*
- * 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...
+ * Could not find a routine for the named subcommand so generate a standard
+ * failure message. The one odd case compared with a standard
+ * ensemble-like command is where a namespace has no exported commands at
+ * all...
*/
Tcl_ResetResult(interp);
@@ -1979,7 +1993,7 @@ NsEnsembleImplementationCmdNR(
int
TclClearRootEnsemble(
- ClientData data[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -1992,8 +2006,8 @@ TclClearRootEnsemble(
*
* TclInitRewriteEnsemble --
*
- * Applies a rewrite of arguments so that an ensemble subcommand will
- * report error messages correctly for the overall command.
+ * Applies a rewrite of arguments so that an ensemble subcommand
+ * correctly reports any error messages for the overall command.
*
* Results:
* Whether this is the first rewrite applied, a value which must be
@@ -2071,7 +2085,7 @@ TclResetRewriteEnsemble(
*
* TclSpellFix --
*
- * Record a spelling correction that needs making in the generation of
+ * Records a spelling correction that needs making in the generation of
* the WrongNumArgs usage message.
*
* Results:
@@ -2085,8 +2099,8 @@ TclResetRewriteEnsemble(
static int
FreeER(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
@@ -2123,7 +2137,7 @@ TclSpellFix(
*/
size = iPtr->ensembleRewrite.numRemovedObjs + objc
- - iPtr->ensembleRewrite.numInsertedObjs;
+ - iPtr->ensembleRewrite.numInsertedObjs;
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
@@ -2136,8 +2150,8 @@ TclSpellFix(
if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
/*
- * Misspelled value was inserted. We cannot directly jump to the bad
- * value, but have to search.
+ * Misspelled value was inserted. Cannot directly jump to the bad
+ * value. Must search.
*/
idx = 1;
@@ -2168,9 +2182,9 @@ TclSpellFix(
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
- Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+ Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
- store = ckalloc(size * sizeof(Tcl_Obj *));
+ store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *));
memcpy(store, iPtr->ensembleRewrite.sourceObjs,
size * sizeof(Tcl_Obj *));
@@ -2249,22 +2263,22 @@ TclFetchEnsembleRoot(
/*
* ----------------------------------------------------------------------
*
- * EnsmebleUnknownCallback --
+ * EnsembleUnknownCallback --
*
- * 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).
+ * Helper for the ensemble engine. Calls the routine registered for
+ * "ensemble unknown" case. See the user documentation of the
+ * ensemble unknown handler for details. Only called when such a
+ * function is defined, and is only called once per ensemble dispatch.
+ * I.e. even 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.
+ * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid
+ * TCL_ERROR - Something went wrong. Error message in interpreter.
*
* Side effects:
- * Calls the Tcl interpreter, so arbitrary.
+ * Arbitrary, due to evaluation of script provided by client.
*
* ----------------------------------------------------------------------
*/
@@ -2277,28 +2291,28 @@ EnsembleUnknownCallback(
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
- int paramc, i, result, prefixObjc;
+ int paramc, i, prefixObjc;
+ int result;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
- * Create the unknown command callback to determine what to do.
+ * 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++) {
+ for (i = 1 ; i < objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
- TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ TclListObjGetElementsM(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!
+ * Call the "unknown" handler. No attempt to NRE-enable this as deep
+ * recursion through unknown handlers is perverse. It is always an error
+ * for an unknown handler to delete its ensemble. Don't do that.
*/
Tcl_Preserve(ensemblePtr);
@@ -2316,10 +2330,9 @@ EnsembleUnknownCallback(
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.
+ * On success the result is a list of words that form the command to be
+ * executed. If the list is empty, the ensemble should have been updated,
+ * so ask the ensemble engine to reparse the original command.
*/
if (result == TCL_OK) {
@@ -2328,13 +2341,9 @@ EnsembleUnknownCallback(
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.
- */
+ /* A non-empty list is the replacement command. */
- if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
+ if (TclListObjLengthM(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
TclDecrRefCount(*prefixObjPtr);
Tcl_AddErrorInfo(interp, "\n while parsing result of "
"ensemble unknown subcommand handler");
@@ -2345,7 +2354,7 @@ EnsembleUnknownCallback(
}
/*
- * Namespace alive & empty result => reparse.
+ * Empty result => reparse.
*/
TclDecrRefCount(*prefixObjPtr);
@@ -2353,7 +2362,7 @@ EnsembleUnknownCallback(
}
/*
- * Oh no! An exceptional result. Convert to an error.
+ * Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
@@ -2393,16 +2402,16 @@ EnsembleUnknownCallback(
*
* 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.)
+ * Caches what has been computed so far to minimize string copying.
+ * Starts by deleting any existing representation but reusing the existing
+ * structure if it is an ensembleCmd.
*
* Results:
- * None
+ * None.
*
* Side effects:
- * Alters the internal representation of the first object parameter.
+ * Converts the internal representation of the given object to an
+ * ensembleCmd.
*
*----------------------------------------------------------------------
*/
@@ -2416,22 +2425,19 @@ MakeCachedEnsembleCommand(
{
EnsembleCmdRep *ensembleCmd;
- if (objPtr->typePtr == &ensembleCmdType) {
- ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ ECRGetInternalRep(objPtr, ensembleCmd);
+ if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
/*
- * Kill the old internal rep, and replace it with a brand new one of
- * our own.
+ * Replace any old internal representation with a new one.
*/
- TclFreeIntRep(objPtr);
- ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &ensembleCmdType;
+ ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
+ ECRSetInternalRep(objPtr, ensembleCmd);
}
/*
@@ -2453,17 +2459,16 @@ MakeCachedEnsembleCommand(
*
* 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.
+ * Destroys the data structure used to represent an ensemble. Called when
+ * the procedure for the ensemble is deleted, which happens automatically
+ * if the namespace for the ensemble is deleted. Deleting the procedure
+ * for an ensemble is the right way to initiate cleanup.
*
* Results:
* None.
*
* Side effects:
- * Memory is (eventually) deallocated.
+ * Memory is eventually deallocated.
*
*----------------------------------------------------------------------
*/
@@ -2479,7 +2484,7 @@ ClearTable(
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
@@ -2490,15 +2495,12 @@ ClearTable(
static void
DeleteEnsembleConfig(
- ClientData clientData)
+ void *clientData)
{
- EnsembleConfig *ensemblePtr = clientData;
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
- /*
- * Unlink from the ensemble chain if it has not been marked as having been
- * done already.
- */
+ /* Unlink from the ensemble chain if it not already marked as unlinked. */
if (ensemblePtr->next != ensemblePtr) {
EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
@@ -2524,7 +2526,7 @@ DeleteEnsembleConfig(
ensemblePtr->flags |= ENSEMBLE_DEAD;
/*
- * Kill the pointer-containing fields.
+ * Release the fields that contain pointers.
*/
ClearTable(ensemblePtr);
@@ -2542,10 +2544,9 @@ DeleteEnsembleConfig(
}
/*
- * 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.)
+ * Arrange for the structure to be reclaimed. This is complex because it is
+ * necessary to react sensibly when an ensemble is deleted during its
+ * initialisation, particularly in the case of an unknown callback.
*/
Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
@@ -2556,10 +2557,11 @@ DeleteEnsembleConfig(
*
* BuildEnsembleConfig --
*
- * Create the internal data structures that describe how an ensemble
- * looks, being a hash mapping from the simple command name to the Tcl list
- * that describes the implementation prefix words, and a sorted array of
- * the names to allow for reasonably efficient unambiguous prefix handling.
+ * Creates the internal data structures that describe how an ensemble
+ * looks. The structures are a hash map 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
+ * handling of an unambiguous prefix.
*
* Results:
* None.
@@ -2567,7 +2569,7 @@ DeleteEnsembleConfig(
* 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.
+ * may be an expensive operation.
*
*----------------------------------------------------------------------
*/
@@ -2576,10 +2578,10 @@ 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_HashSearch search; /* Used for scanning the commands in
+ * the namespace for this ensemble. */
+ int i, j;
+ int isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
@@ -2591,17 +2593,17 @@ BuildEnsembleConfig(
if (subList) {
int subc;
Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
- char *name;
+ const char *name;
/*
* There is a list of exactly what subcommands go in the table.
- * Must determine the target for each.
+ * Determine the target for each.
*/
- TclListObjGetElements(NULL, subList, &subc, &subv);
+ TclListObjGetElementsM(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
- * Strange case where explicit list of subcommands is same value
+ * Unusual case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
@@ -2625,7 +2627,9 @@ BuildEnsembleConfig(
}
}
} else {
- /* Usual case where we can freely act on the list and dict. */
+ /*
+ * Usual case where we can freely act on the list and dict.
+ */
for (i = 0; i < subc; i++) {
name = TclGetString(subv[i]);
@@ -2634,7 +2638,10 @@ BuildEnsembleConfig(
continue;
}
- /* Lookup target in the dictionary */
+ /*
+ * Lookup target in the dictionary.
+ */
+
if (mapDict) {
Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
if (target) {
@@ -2645,11 +2652,12 @@ BuildEnsembleConfig(
}
/*
- * target was not in the dictionary 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).
+ * Target was not in the dictionary. Map onto the namespace.
+ * In this case there is no guarantee that the command
+ * is actually there. It is the responsibility of the
+ * programmer (or [::unknown] of course) to provide the procedure.
*/
+
cmdObj = Tcl_NewStringObj(name, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
@@ -2658,9 +2666,9 @@ BuildEnsembleConfig(
}
} else if (mapDict) {
/*
- * 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.
+ * No subcmd list, but there is a mapping dictionary, so
+ * use the keys of that. Convert the contents of the dictionary into the
+ * form required for the internal hashtable of the ensemble.
*/
Tcl_DictSearch dictSearch;
@@ -2670,7 +2678,7 @@ BuildEnsembleConfig(
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
- char *name = TclGetString(keyObj);
+ const char *name = TclGetString(keyObj);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
Tcl_SetHashValue(hPtr, valueObj);
@@ -2679,24 +2687,21 @@ BuildEnsembleConfig(
}
} 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.
+ * Use the array of patterns and the hash table whose keys are the
+ * commands exported by the namespace. The corresponding values do not
+ * matter here. Filter the commands in the namespace against the
+ * patterns in the export list to find out what commands are actually
+ * exported. Use an intermediate hash table to make memory management
+ * easier and to make exact matching much easier.
*
- * Suggestion for future enhancement: compute the unique prefixes and
- * place them in the hash too, which should make for even faster
- * matching.
+ * Suggestion for future enhancement: Compute the unique prefixes and
+ * place them in the hash too 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);
+ (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
@@ -2735,22 +2740,22 @@ BuildEnsembleConfig(
/*
* 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.
+ * determine things like whether a string is a prefix of another, at least
+ * not without a lot of preparation, and they're not useful for 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.
+ * Do this by filling an array with the names: 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 run quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
- ckalloc(sizeof(char *) * hash->numEntries);
+ (char **)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:
+ * Fill the array from both ends as this reduces the likelihood of
+ * performance problems in qsort(). 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++) {
@@ -2758,27 +2763,27 @@ BuildEnsembleConfig(
* }
*
* 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.
+ * commands in the namespace are declared in a sorted fashion, which is an
+ * ordering some people like, and the hashing functions or the command
+ * names themselves are fairly unfortunate. Filling from both ends means
+ * that 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);
+ ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
if (hPtr == NULL) {
break;
}
- ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
+ ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
- qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
+ qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
@@ -2788,8 +2793,7 @@ BuildEnsembleConfig(
*
* NsEnsembleStringOrder --
*
- * Helper function to compare two pointers to two strings for use with
- * qsort().
+ * Helper to for uset with sort() that compares two string pointers.
*
* Results:
* -1 if the first string is smaller, 1 if the second string is smaller,
@@ -2832,14 +2836,14 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
+ ECRGetInternalRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
- objPtr->typePtr = NULL;
}
/*
@@ -2865,11 +2869,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
+ EnsembleCmdRep *ensembleCmd;
+ EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
+
+ ECRGetInternalRep(objPtr, ensembleCmd);
+ ECRSetInternalRep(copyPtr, ensembleCopy);
- copyPtr->typePtr = &ensembleCmdType;
- copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
@@ -2916,14 +2921,15 @@ TclCompileEnsemble(
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
- int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int result, flags = 0, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
- unsigned numBytes;
+ int i, len;
+ TCL_HASH_TYPE numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
- if (parsePtr->numWords < depth + 1) {
+ if (parsePtr->numWords <= depth) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -2992,11 +2998,11 @@ TclCompileEnsemble(
const char *str;
Tcl_Obj *matchObj = NULL;
- if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, listObj, &len, &elems) != TCL_OK) {
goto failed;
}
for (i=0 ; i<len ; i++) {
- str = Tcl_GetStringFromObj(elems[i], &sclen);
+ str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
@@ -3112,7 +3118,7 @@ TclCompileEnsemble(
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
- if (TclListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
} else if (len != 1) {
/*
@@ -3166,7 +3172,7 @@ TclCompileEnsemble(
}
/*
- * Now we've done the mapping process, can now actually try to compile.
+ * Now that the mapping process is done we actually try to compile.
* If there is a subcommand compiler and that successfully produces code,
* we'll use that. Otherwise, we fall back to generating opcodes to do the
* invoke at runtime.
@@ -3183,7 +3189,7 @@ TclCompileEnsemble(
* Throw out any line information generated by the failed compile attempt.
*/
- while (mapPtr->nuloc - 1 > eclIndex) {
+ while (mapPtr->nuloc > eclIndex + 1) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
@@ -3250,10 +3256,11 @@ TclAttemptCompileProc(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
- int result, i;
+ int result;
+ int i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
- unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
@@ -3266,9 +3273,9 @@ TclAttemptCompileProc(
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
- * This will be wrong, but it will not matter, and it will put the
- * tokens for the arguments in the right place without the needed to
- * allocate a synthetic Tcl_Parse struct, or copy tokens around.
+ * This will be wrong but it will not matter, and it will put the
+ * tokens for the arguments in the right place without the need to
+ * allocate a synthetic Tcl_Parse struct or copy tokens around.
*/
for (i = 0; i < depth - 1; i++) {
@@ -3385,8 +3392,9 @@ CompileToInvokedCommand(
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
- char *bytes;
- int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ const char *bytes;
+ int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ int i, numWords, length;
/*
* Push the words of the command. Take care; the command words may be
@@ -3394,19 +3402,19 @@ CompileToInvokedCommand(
* difference. Hence the call to TclContinuationsEnterDerived...
*/
- TclListObjGetElements(NULL, replacements, &numWords, &words);
+ TclListObjGetElementsM(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
- if (i > 0 && i < numWords+1) {
- bytes = Tcl_GetStringFromObj(words[i-1], &length);
+ if (i > 0 && i <= numWords) {
+ bytes = TclGetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- int literal = TclRegisterNewLiteral(envPtr,
- tokPtr[1].start, tokPtr[1].size);
+ int literal = TclRegisterLiteral(envPtr,
+ tokPtr[1].start, tokPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
@@ -3427,11 +3435,11 @@ CompileToInvokedCommand(
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 2788c7e..1378708 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -6,8 +6,8 @@
* is primarily responsible for keeping the "env" arrays in sync with the
* system environment variables.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,10 +19,10 @@ TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
-# define tenviron2utfdstr(tenvstr, len, dstr) \
- Tcl_WinTCharToUtf((TCHAR *)tenvstr, len, dstr)
-# define utf2tenvirondstr(str, len, dstr) \
- (const WCHAR *)Tcl_WinUtfToTChar(str, len, dstr)
+# define tenviron2utfdstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+# define utf2tenvirondstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (const WCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
@@ -624,10 +624,9 @@ TclGetEnv(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static char *
EnvTraceProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 3c4ff74..1e2e7bf 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -5,15 +5,16 @@
* background errors, exit handlers, and the "vwait" and "update" command
* functions.
*
- * Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Zoran Vasiljevic.
+ * Copyright © 1990-1994 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2004 Zoran Vasiljevic.
*
* 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 "tclUuid.h"
/*
* The data structure below is used to report background errors. One such
@@ -49,13 +50,26 @@ typedef struct {
} ErrAssocData;
/*
+ * For each "vwait" event source a structure of the following type
+ * is used:
+ */
+
+typedef struct {
+ int *donePtr; /* Pointer to flag to signal or NULL. */
+ int sequence; /* Order of occurrence. */
+ int mask; /* 0, or TCL_READABLE/TCL_WRITABLE. */
+ Tcl_Obj *sourceObj; /* Name of the event source, either a
+ * variable name or channel name. */
+} VwaitItem;
+
+/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
- ClientData clientData; /* One word of information to pass to proc. */
+ void *clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
@@ -100,22 +114,25 @@ typedef struct ThreadSpecificData {
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-#ifdef TCL_THREADS
+#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
- ClientData clientData; /* The one argument to Main() */
+ void *clientData; /* The one argument to Main() */
} ThreadClientData;
-static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
+static Tcl_ThreadCreateType NewThreadProc(void *clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
-static void BgErrorDeleteProc(ClientData clientData,
+static void BgErrorDeleteProc(void *clientData,
Tcl_Interp *interp);
-static void HandleBgErrors(ClientData clientData);
-static char * VwaitVarProc(ClientData clientData,
+static void HandleBgErrors(void *clientData);
+static void VwaitChannelReadProc(void *clientData, int mask);
+static void VwaitChannelWriteProc(void *clientData, int mask);
+static void VwaitTimeoutProc(void *clientData);
+static char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
@@ -139,6 +156,8 @@ static void FinalizeThread(int quick);
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef Tcl_BackgroundError
void
Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
@@ -146,6 +165,7 @@ Tcl_BackgroundError(
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
+#endif /* TCL_NO_DEPRECATED */
void
Tcl_BackgroundException(
@@ -198,7 +218,7 @@ Tcl_BackgroundException(
static void
HandleBgErrors(
- ClientData clientData) /* Pointer to ErrAssocData structure. */
+ void *clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
@@ -226,7 +246,7 @@ HandleBgErrors(
errPtr = assocPtr->firstBgPtr;
- TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
+ TclListObjGetElementsM(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
@@ -308,7 +328,7 @@ HandleBgErrors(
int
TclDefaultBgErrorHandlerObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -593,8 +613,8 @@ TclGetBgErrorHandler(
static void
BgErrorDeleteProc(
- ClientData clientData, /* Pointer to ErrAssocData structure. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ void *clientData, /* Pointer to ErrAssocData structure. */
+ TCL_UNUSED(Tcl_Interp *))
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
@@ -632,7 +652,7 @@ BgErrorDeleteProc(
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
@@ -665,7 +685,7 @@ Tcl_CreateExitHandler(
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
@@ -698,7 +718,7 @@ TclCreateLateExitHandler(
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
@@ -741,7 +761,7 @@ Tcl_DeleteExitHandler(
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
@@ -784,7 +804,7 @@ TclDeleteLateExitHandler(
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -817,7 +837,7 @@ Tcl_CreateThreadExitHandler(
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -999,7 +1019,7 @@ Tcl_Exit(
/*
*-------------------------------------------------------------------------
*
- * TclInitSubsystems --
+ * Tcl_InitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
@@ -1013,7 +1033,7 @@ Tcl_Exit(
* down another.
*
* Results:
- * The full Tcl version.
+ * The full Tcl version with build information.
*
* Side effects:
* Varied, see the respective initialization routines.
@@ -1023,18 +1043,91 @@ Tcl_Exit(
MODULE_SCOPE const TclStubs tclStubs;
+#ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+#endif
+
static const struct {
const TclStubs *stubs;
const char version[256];
} stubInfo = {
- &tclStubs, {TCL_PATCH_LEVEL}
-};
+ &tclStubs, {TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID)
+#if defined(__clang__) && defined(__clang_major__)
+ ".clang-" STRINGIFY(__clang_major__)
+#if __clang_minor__ < 10
+ "0"
+#endif
+ STRINGIFY(__clang_minor__)
+#endif
+#ifdef TCL_COMPILE_DEBUG
+ ".compiledebug"
+#endif
+#ifdef TCL_COMPILE_STATS
+ ".compilestats"
+#endif
+#if defined(__cplusplus) && !defined(__OBJC__)
+ ".cplusplus"
+#endif
+#ifndef NDEBUG
+ ".debug"
+#endif
+#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
+ ".gcc-" STRINGIFY(__GNUC__)
+#if __GNUC_MINOR__ < 10
+ "0"
+#endif
+ STRINGIFY(__GNUC_MINOR__)
+#endif
+#ifdef __INTEL_COMPILER
+ ".icc-" STRINGIFY(__INTEL_COMPILER)
+#endif
+#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL)
+ ".ilp32"
+#endif
+#ifdef TCL_MEM_DEBUG
+ ".memdebug"
+#endif
+#if defined(_MSC_VER)
+ ".msvc-" STRINGIFY(_MSC_VER)
+#endif
+#ifdef USE_NMAKE
+ ".nmake"
+#endif
+#ifdef TCL_NO_DEPRECATED
+ ".no-deprecate"
+#endif
+#if !TCL_THREADS
+ ".no-thread"
+#endif
+#ifndef TCL_CFG_OPTIMIZED
+ ".no-optimize"
+#endif
+#ifdef __OBJC__
+ ".objective-c"
+#if defined(__cplusplus)
+ "plusplus"
+#endif
+#endif
+#ifdef TCL_CFG_PROFILED
+ ".profile"
+#endif
+#ifdef PURIFY
+ ".purify"
+#endif
+#ifdef STATIC_BUILD
+ ".static"
+#endif
+#if TCL_UTF_MAX < 4
+ ".utf-16"
+#endif
+}};
const char *
-TclInitSubsystems(void)
+Tcl_InitSubsystems(void)
{
if (inExit != 0) {
- Tcl_Panic("TclInitSubsystems called while exiting");
+ Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -1057,6 +1150,9 @@ TclInitSubsystems(void)
#if defined(USE_TCLALLOC) && USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
+ TclInitThreadAlloc(); /* Setup thread allocator caches */
+#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
@@ -1232,7 +1328,7 @@ Tcl_Finalize(void)
* Close down the thread-specific object allocator.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
@@ -1402,78 +1498,435 @@ TclInThreadExit(void)
int
Tcl_VwaitObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int done, foundEvent;
- const char *nameString;
+ int i, done = 0, timedOut = 0, foundEvent, any = 1, timeout = 0;
+ int numItems = 0, extended = 0, result, mode, mask = TCL_ALL_EVENTS;
+ Tcl_InterpState saved = NULL;
+ Tcl_TimerToken timer = NULL;
+ Tcl_Time before, after;
+ Tcl_Channel chan;
+ Tcl_WideInt diff = -1;
+ VwaitItem localItems[32], *vwaitItems = localItems;
+ static const char *const vWaitOptionStrings[] = {
+ "-all", "-extended", "-nofileevents", "-noidleevents",
+ "-notimerevents", "-nowindowevents", "-readable",
+ "-timeout", "-variable", "-writable", "--", NULL
+ };
+ enum vWaitOptions {
+ OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS,
+ OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE,
+ OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST
+ } index;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name");
- return TCL_ERROR;
+ if ((objc == 2) && (strcmp(Tcl_GetString(objv[1]), "--") != 0)) {
+ /*
+ * Legacy "vwait" syntax, skip option handling.
+ */
+ i = 1;
+ goto endOfOptionLoop;
}
- nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done) != TCL_OK) {
- return TCL_ERROR;
- };
- done = 0;
+
+ if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
+ vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1));
+ }
+
+ for (i = 1; i < objc; i++) {
+ const char *name;
+
+ name = TclGetString(objv[i]);
+ if (name[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0,
+ &index) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case OPT_ALL:
+ any = 0;
+ break;
+ case OPT_EXTD:
+ extended = 1;
+ break;
+ case OPT_NO_FEVTS:
+ mask &= ~TCL_FILE_EVENTS;
+ break;
+ case OPT_NO_IEVTS:
+ mask &= ~TCL_IDLE_EVENTS;
+ break;
+ case OPT_NO_TEVTS:
+ mask &= ~TCL_TIMER_EVENTS;
+ break;
+ case OPT_NO_WEVTS:
+ mask &= ~TCL_WINDOW_EVENTS;
+ break;
+ case OPT_TIMEOUT:
+ if (++i >= objc) {
+ needArg:
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "argument required for \"%s\"", vWaitOptionStrings[index]));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (timeout < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timeout must be positive", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ break;
+ case OPT_LAST:
+ i++;
+ goto endOfOptionLoop;
+ case OPT_VARIABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_READABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for reading",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_READABLE,
+ VwaitChannelReadProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_READABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_WRITABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for writing",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_WRITABLE,
+ VwaitChannelWriteProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_WRITABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ }
+ }
+
+ endOfOptionLoop:
+ if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
+ TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't wait: would block forever", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timer events disabled with timeout specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ for (result = TCL_OK; i < objc; i++) {
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ break;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ }
+ if (result != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if (!(mask & TCL_FILE_EVENTS)) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "file events disabled with channel(s) specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ if (timeout > 0) {
+ vwaitItems[numItems].donePtr = &timedOut;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = NULL;
+ timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc,
+ &vwaitItems[numItems]);
+ Tcl_GetTime(&before);
+ } else {
+ timeout = 0;
+ }
+
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * "vwait" is equivalent to "update",
+ * "vwait -nofileevents -notimerevents -nowindowevents"
+ * is equivalent to "update idletasks"
+ */
+ any = 1;
+ mask |= TCL_DONT_WAIT;
+ }
+
foundEvent = 1;
- while (!done && foundEvent) {
- foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ while (!timedOut && foundEvent &&
+ ((!any && (done < numItems)) || (any && !done))) {
+ foundEvent = Tcl_DoOneEvent(mask);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL);
break;
}
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * Behavior like "update": clear interpreter's result because
+ * event handlers could have executed commands.
+ */
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ goto done;
+ }
}
- Tcl_UntraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done);
if (!foundEvent) {
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't wait for variable \"%s\": would wait forever",
- nameString));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ?
+ "can't wait: would wait forever" :
+ "can't wait for variable(s)/channel(s): would wait forever",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
- if (!done) {
+
+ if (!done && !timedOut) {
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
*/
+ result = TCL_ERROR;
+ goto done;
+ }
- return TCL_ERROR;
+ result = TCL_OK;
+ if (timeout <= 0) {
+ /*
+ * Clear out the interpreter's result, since it may have been set
+ * by event handlers.
+ */
+ Tcl_ResetResult(interp);
+ goto done;
}
/*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
+ * When timeout was specified, report milliseconds left or -1 on timeout.
*/
+ if (timedOut) {
+ diff = -1;
+ } else {
+ Tcl_GetTime(&after);
+ diff = after.sec * 1000 + after.usec / 1000;
+ diff -= before.sec * 1000 + before.usec / 1000;
+ diff = timeout - diff;
+ if (diff < 0) {
+ diff = 0;
+ }
+ }
- Tcl_ResetResult(interp);
- return TCL_OK;
+ done:
+ if ((timeout > 0) && (timer != NULL)) {
+ Tcl_DeleteTimerHandler(timer);
+ }
+ if (result != TCL_OK) {
+ saved = Tcl_SaveInterpState(interp, result);
+ }
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelReadProc,
+ &vwaitItems[i]);
+ }
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelWriteProc,
+ &vwaitItems[i]);
+ }
+ } else {
+ Tcl_UntraceVar2(interp, TclGetString(vwaitItems[i].sourceObj),
+ NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[i]);
+ }
+ }
+
+ if (result == TCL_OK) {
+ if (extended) {
+ int k;
+ Tcl_Obj *listObj, *keyObj;
+
+ TclNewObj(listObj);
+ for (k = 0; k < done; k++) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].sequence != k) {
+ continue;
+ }
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ TclNewLiteralStringObj(keyObj, "readable");
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ TclNewLiteralStringObj(keyObj, "writable");
+ } else {
+ TclNewLiteralStringObj(keyObj, "variable");
+ }
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ vwaitItems[i].sourceObj);
+ }
+ }
+ if (timeout > 0) {
+ TclNewLiteralStringObj(keyObj, "timeleft");
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ Tcl_NewWideIntObj(diff));
+ }
+ Tcl_SetObjResult(interp, listObj);
+ } else if (timeout > 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(diff));
+ }
+ } else {
+ result = Tcl_RestoreInterpState(interp, saved);
+ }
+ if (vwaitItems != localItems) {
+ ckfree(vwaitItems);
+ }
+ return result;
+}
+
+static void
+VwaitChannelReadProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_READABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_READABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitChannelWriteProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_WRITABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_WRITABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitTimeoutProc(
+ void *clientData) /* Pointer to vwait info record. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->donePtr[0] = 1;
+ itemPtr->donePtr = NULL;
+ }
}
static char *
VwaitVarProc(
- ClientData clientData, /* Pointer to integer to set to 1. */
+ void *clientData, /* Pointer to vwait info record. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
- int flags) /* Information about what happened. */
+ TCL_UNUSED(int) /*flags*/) /* Information about what happened. */
{
- int *donePtr = (int *)clientData;
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
- *donePtr = 1;
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
@@ -1498,7 +1951,7 @@ VwaitVarProc(
int
Tcl_UpdateObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1517,7 +1970,7 @@ Tcl_UpdateObjCmd(
}
switch ((enum updateOptionsEnum) optionIndex) {
case OPT_IDLETASKS:
- flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
@@ -1547,7 +2000,7 @@ Tcl_UpdateObjCmd(
return TCL_OK;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1566,10 +2019,10 @@ Tcl_UpdateObjCmd(
static Tcl_ThreadCreateType
NewThreadProc(
- ClientData clientData)
+ void *clientData)
{
ThreadClientData *cdPtr = (ThreadClientData *)clientData;
- ClientData threadClientData;
+ void *threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
@@ -1605,12 +2058,12 @@ int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
- ClientData clientData, /* The one argument to Main() */
+ void *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
+#if TCL_THREADS
ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData));
int result;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a16334a..7ee5471 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3,13 +3,13 @@
*
* This file contains procedures that execute byte-compiled Tcl commands.
*
- * 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-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.
+ * Copyright © 1996-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002-2010 Miguel Sofer.
+ * Copyright © 2005-2007 Donal K. Fellows.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2006-2008 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.
@@ -18,7 +18,8 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
+#include "tclArithSeries.h"
#include <math.h>
#include <assert.h>
@@ -34,14 +35,14 @@
#endif
/*
- * A mask (should be 2**n-1) that is used to work out when the bytecode engine
- * should call Tcl_AsyncReady() to see whether there is a signal that needs
- * handling.
+ * A counter that is used to work out when the bytecode engine should call
+ * Tcl_AsyncReady() to see whether there is a signal that needs handling, and
+ * other expensive periodic operations.
*/
-#ifndef ASYNC_CHECK_COUNT_MASK
-# define ASYNC_CHECK_COUNT_MASK 63
-#endif /* !ASYNC_CHECK_COUNT_MASK */
+#ifndef ASYNC_CHECK_COUNT
+# define ASYNC_CHECK_COUNT 64
+#endif /* !ASYNC_CHECK_COUNT */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -97,9 +98,9 @@ static const char *const resultStrings[] = {
*/
#ifdef TCL_COMPILE_STATS
-long tclObjsAlloced = 0;
-long tclObjsFreed = 0;
-long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+size_t tclObjsAlloced = 0;
+size_t tclObjsFreed = 0;
+size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
@@ -166,14 +167,14 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
* Minimal data required to fully reconstruct the execution state.
*/
-typedef struct TEBCdata {
+typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
- ptrdiff_t *catchTop; /* These fields are used on return TO this */
+ Tcl_Obj **catchTop; /* These fields are used on return TO this */
Tcl_Obj *auxObjList; /* this level: they record the state when a */
CmdFrame cmdFrame; /* new codePtr was received for NR */
/* execution. */
- void *stack[1]; /* Start of the actual combined catch and obj
+ Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
} TEBCdata;
@@ -202,7 +203,7 @@ typedef struct TEBCdata {
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
- auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1; \
+ auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \
Tcl_DecrRefCount(tmpPtr); \
} while (0)
@@ -211,7 +212,7 @@ typedef struct TEBCdata {
*/
#define VarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static inline Var *
VarHashCreateVar(
@@ -424,7 +425,7 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
-#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
+#define CURR_DEPTH ((size_t)(tosPtr - initTosPtr))
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
@@ -437,9 +438,9 @@ VarHashCreateVar(
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned) (pc - codePtr->codeStart), \
+ fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
@@ -453,9 +454,9 @@ VarHashCreateVar(
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned) (pc - codePtr->codeStart), \
+ fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
@@ -502,61 +503,26 @@ VarHashCreateVar(
/*
* Macro used in this file to save a function call for common uses of
- * TclGetNumberFromObj(). The ANSI C "prototype" is:
+ * Tcl_GetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- * ClientData *ptrPtr, int *tPtr);
+ * void **ptrPtr, int *tPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
-#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
- ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
- ? (*(tPtr) = TCL_NUMBER_NAN) \
- : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
- (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
- TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclWideIntType) \
- ? (*(tPtr) = TCL_NUMBER_WIDE, \
- *(ptrPtr) = (ClientData) \
+ ((TclHasInternalRep((objPtr), &tclIntType)) \
+ ? (*(tPtr) = TCL_NUMBER_INT, \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
- ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
+ TclHasInternalRep((objPtr), &tclDoubleType) \
+ ? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
- TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
-
-/*
- * Macro used in this file to save a function call for common uses of
- * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
- *
- * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- * int *intPtr);
- */
-
-#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- ((((objPtr)->typePtr == &tclIntType) \
- || ((objPtr)->typePtr == &tclBooleanType)) \
- ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
+ ? TCL_ERROR : \
+ Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -586,40 +552,6 @@ VarHashCreateVar(
* 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.
- */
-
-static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
-static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
-
-/*
- * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
- * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
- * powers of i+3; Exp32Value[i] gives the corresponding powers.
- */
-
-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 long Exp32Value[] = {
- 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
- 129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
- 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
- 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
- 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
- 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)
-
/*
* Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
* Tcl_WideInt.
@@ -723,7 +655,6 @@ static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)371293*371293*371293*13*13
};
static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
-#endif /* (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) */
/*
* Markers for ExecuteExtendedBinaryMathOp.
@@ -732,30 +663,27 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1)
#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2)
#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3)
+#define OUT_OF_MEMORY ((Tcl_Obj *) -4)
/*
* Declarations for local procedures to this file:
*/
#ifdef TCL_COMPILE_STATS
-static int EvalStatsCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc EvalStatsCmd;
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static const char * GetOpcodeName(const unsigned char *pc);
static void PrintByteCodeInfo(ByteCode *codePtr);
static const char * StringForResultCode(int result);
static void ValidatePcAndStackTop(ByteCode *codePtr,
- const unsigned char *pc, int stackTop,
+ const unsigned char *pc, size_t stackTop,
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);
@@ -830,20 +758,22 @@ ReleaseDictIterator(
{
Tcl_DictSearch *searchPtr;
Tcl_Obj *dictPtr;
+ const Tcl_ObjInternalRep *irPtr;
+
+ irPtr = TclFetchInternalRep(objPtr, &dictIteratorType);
+ assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
- searchPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
- dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
-
- objPtr->typePtr = NULL;
}
/*
@@ -867,6 +797,7 @@ ReleaseDictIterator(
*----------------------------------------------------------------------
*/
+#if defined(TCL_COMPILE_STATS) || defined(TCL_COMPILE_DEBUG)
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
@@ -874,7 +805,7 @@ InitByteCodeExecution(
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
- if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
+ if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
@@ -883,6 +814,15 @@ InitByteCodeExecution(
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
+
+#else
+
+static void
+InitByteCodeExecution(
+ TCL_UNUSED(Tcl_Interp *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -913,14 +853,14 @@ TclCreateExecEnv(
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
- ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
- ExecStack *esPtr = ckalloc(TclOffset(ExecStack, stackWords)
+ ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
+ ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords)
+ size * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
- TclNewBooleanObj(eePtr->constants[0], 0);
+ TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
- TclNewBooleanObj(eePtr->constants[1], 1);
+ TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
eePtr->callbackPtr = NULL;
@@ -1180,10 +1120,10 @@ GrowEvaluationStack(
newElems = needed;
#endif
- newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
+ newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
oldPtr = esPtr;
- esPtr = ckalloc(newBytes);
+ esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
@@ -1282,7 +1222,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1407,7 +1347,7 @@ int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- Tcl_Obj *objPtr, /* Points to Tcl object containing expression
+ Tcl_Obj *objPtr, /* Points to Tcl object containing expression
* to evaluate. */
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
@@ -1424,12 +1364,12 @@ Tcl_ExprObj(
static int
CopyCallback(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- Tcl_Obj **resultPtrPtr = data[0];
- Tcl_Obj *resultPtr = data[1];
+ Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0];
+ Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
*resultPtrPtr = resultPtr;
@@ -1482,12 +1422,12 @@ Tcl_NRExprObj(
static int
ExprObjCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
- Tcl_InterpState state = data[0];
- Tcl_Obj *resultPtr = data[1];
+ Tcl_InterpState state = (Tcl_InterpState)data[0];
+ Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
@@ -1506,11 +1446,9 @@ ExprObjCallback(
*
* 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,
+ * The Tcl_ObjType of objPtr is changed to the "exprcode" 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.
@@ -1534,19 +1472,23 @@ CompileExprObj(
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &exprCodeType) {
+
+ ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
- FreeExprCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &exprCodeType) {
+
+ if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
@@ -1563,7 +1505,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -1574,10 +1516,8 @@ CompileExprObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1621,8 +1561,8 @@ CompileExprObj(
static void
DupExprCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
return;
}
@@ -1649,12 +1589,11 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+ ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);
+ assert(codePtr != NULL);
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
@@ -1690,7 +1629,8 @@ TclCompileObj(
* compilation). Otherwise, check that it is "fresh" enough.
*/
- if (objPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
@@ -1708,7 +1648,6 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1775,9 +1714,9 @@ TclCompileObj(
return codePtr;
}
- eclPtr = Tcl_GetHashValue(hePtr);
+ eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
redo = 0;
- ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxCopyPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
@@ -1836,7 +1775,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1870,9 +1809,10 @@ TclIncrObj(
Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr)
{
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
int type1, type2;
mp_int value, incr;
+ mp_err err;
if (Tcl_IsShared(valuePtr)) {
Tcl_Panic("%s called with shared object", "TclIncrObj");
@@ -1895,37 +1835,6 @@ TclIncrObj(
return TCL_ERROR;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- long augend = *((const long *) ptr1);
- long addend = *((const long *) ptr2);
- long sum = (long)((unsigned long)augend + (unsigned long)addend);
-
- /*
- * Overflow when (augend and sum have different sign) and (augend and
- * addend have the same sign). This is encapsulated in the Overflowing
- * macro.
- */
-
- if (!Overflowing(augend, addend, sum)) {
- TclSetLongObj(valuePtr, sum);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- {
- Tcl_WideInt w1 = (Tcl_WideInt) augend;
- Tcl_WideInt w2 = (Tcl_WideInt) addend;
-
- /*
- * We know the sum value is outside the long range, so we use the
- * macro form that doesn't range test again.
- */
-
- TclSetWideIntObj(valuePtr, w1 + w2);
- return TCL_OK;
- }
-#endif
- }
-
if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
/*
* Produce error message (reparse?!)
@@ -1943,12 +1852,11 @@ TclIncrObj(
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
Tcl_WideInt w1, w2, sum;
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, incrPtr, &w2);
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
/*
@@ -1956,16 +1864,18 @@ TclIncrObj(
*/
if (!Overflowing(w1, w2, sum)) {
- Tcl_SetWideIntObj(valuePtr, sum);
+ TclSetIntObj(valuePtr, sum);
return TCL_OK;
}
}
-#endif
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
- mp_add(&value, &incr, &value);
+ err = mp_add(&value, &incr, &value);
mp_clear(&incr);
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetBignumObj(valuePtr, &value);
return TCL_OK;
}
@@ -2024,8 +1934,8 @@ ArgumentBCEnter(
*----------------------------------------------------------------------
*/
#define bcFramePtr (&TD->cmdFrame)
-#define initCatchTop ((ptrdiff_t *) (TD->stack-1))
-#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
+#define initCatchTop (TD->stack-1)
+#define initTosPtr (initCatchTop+codePtr->maxExceptDepth)
#define esPtr (iPtr->execEnvPtr->execStackPtr)
int
@@ -2040,7 +1950,7 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- codePtr->refCount++;
+ TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
@@ -2096,7 +2006,7 @@ TclNRExecuteByteCode(
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
- /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags));
+ /* cleanup */ NULL, INT2PTR(iPtr->evalFlags));
/*
* Reset discard result flag - because it is applicable for this call only,
@@ -2109,7 +2019,7 @@ TclNRExecuteByteCode(
static int
TEBCresume(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2136,8 +2046,14 @@ TEBCresume(
* sporadically: no special need for speed.
*/
- int instructionCount = 0; /* Counter that is used to work out when to
- * call Tcl_AsyncReady() */
+ unsigned interruptCounter = 1;
+ /* Counter that is used to work out when to
+ * call Tcl_AsyncReady(). This must be 1
+ * initially so that we call the async-check
+ * stanza early, otherwise there are command
+ * sequences that can make the interpreter
+ * busy-loop without an opportunity to
+ * recognise an interrupt. */
const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
int traceInstructions; /* Whether we are doing instruction-level
@@ -2155,7 +2071,7 @@ TEBCresume(
* used too frequently
*/
- TEBCdata *TD = data[0];
+ TEBCdata *TD = (TEBCdata *)data[0];
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
@@ -2167,7 +2083,7 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
- const unsigned char *pc = data[1];
+ const unsigned char *pc = (const unsigned char *)data[1];
/* The current program counter. */
unsigned char inst; /* The currently running instruction */
@@ -2189,8 +2105,8 @@ TEBCresume(
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
- int objc = 0;
- int opnd, length, pcAdjustment;
+ int length, objc = 0;
+ int opnd, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
@@ -2206,7 +2122,7 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
- fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
+ fprintf(stdout, " Starting stack top=%" TCL_Z_MODIFIER "u\n", CURR_DEPTH);
fflush(stdout);
}
#endif
@@ -2357,10 +2273,11 @@ TEBCresume(
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
+ * ASYNC_CHECK_COUNT instructions.
*/
- if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
+ if ((--interruptCounter) == 0) {
+ interruptCounter = ASYNC_CHECK_COUNT;
DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
result = Tcl_AsyncInvoke(interp, result);
@@ -2409,7 +2326,7 @@ TEBCresume(
CHECK_STACK();
if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
+ fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u ", iPtr->numLevels, CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
@@ -2508,7 +2425,7 @@ TEBCresume(
{
CoroutineData *corPtr;
- int yieldParameter;
+ void *yieldParameter;
case INST_YIELD:
corPtr = iPtr->execEnvPtr->corPtr;
@@ -2529,14 +2446,14 @@ TEBCresume(
if (traceInstructions) {
TRACE_APPEND(("YIELD...\n"));
} else {
- fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
Tcl_GetString(OBJ_AT_TOS));
}
fflush(stdout);
}
#endif
- yieldParameter = 0;
+ yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/
Tcl_SetObjResult(interp, OBJ_AT_TOS);
goto doYield;
@@ -2572,9 +2489,9 @@ TEBCresume(
TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
} else {
/* FIXME: What is the right thing to trace? */
- fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
- Tcl_GetString(valuePtr));
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2586,11 +2503,12 @@ TEBCresume(
* 'yieldParameter').
*/
- Tcl_IncrRefCount(valuePtr);
iPtr->execEnvPtr = corPtr->callerEEPtr;
+ Tcl_IncrRefCount(valuePtr);
TclSetTailcall(interp, valuePtr);
+ corPtr->yieldPtr = valuePtr;
iPtr->execEnvPtr = corPtr->eePtr;
- yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
+ yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/
doYield:
/* TIP #280: Record the last piece of info needed by
@@ -2608,7 +2526,7 @@ TEBCresume(
cleanup = 1;
TEBC_YIELD();
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(yieldParameter), NULL, NULL);
+ yieldParameter, NULL, NULL);
return TCL_OK;
}
@@ -2734,154 +2652,19 @@ TEBCresume(
}
break;
- case INST_STR_CONCAT1: {
- int appendLen = 0;
- char *bytes, *p;
- Tcl_Obj **currPtr;
- int onlyb = 1;
+ case INST_STR_CONCAT1:
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.
- */
-
- 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;
- }
- }
- }
-
- if (appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
-
- /*
- * If nothing is to be appended, just return the first object by
- * dropping all the others from the stack; this saves both the
- * computation and copy of the string rep of the first object,
- * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
- */
-
- if (appendLen == 0) {
- TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
- NEXT_INST_V(2, (opnd-1), 0);
- }
-
- /*
- * If the first object is shared, we need a new obj for the result;
- * otherwise, we can reuse the first object. In any case, make sure it
- * has enough room to accomodate all the concatenated bytes. Note that
- * if it is unshared its bytes are copied by ckrealloc, so that we set
- * the loop parameters to avoid copying them again: p points to the
- * end of the already copied bytes, currPtr to the second object.
- */
-
- objResultPtr = OBJ_AT_DEPTH(opnd-1);
- 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);
- }
-#ifndef TCL_COMPILE_DEBUG
- 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 = 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, 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);
- }
-#ifndef 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.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
- memcpy(p, bytes, length);
- p += length;
- }
- }
+ objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
+ TCL_STRING_IN_PLACE);
+ if (objResultPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
- }
+ break;
case INST_CONCAT_STK:
/*
@@ -2893,6 +2676,7 @@ TEBCresume(
objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
+ break;
case INST_EXPAND_START:
/*
@@ -2909,10 +2693,10 @@ TEBCresume(
*/
TclNewObj(objPtr);
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
+ objPtr->internalRep.twoPtrValue.ptr2 = UINT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
- TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
+ TRACE(("=> mark depth as %" TCL_Z_MODIFIER "u\n", CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
@@ -2924,7 +2708,7 @@ TEBCresume(
*/
CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
+ objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
/* Ugly abuse! */
@@ -2935,7 +2719,8 @@ TEBCresume(
case INST_EXPAND_STKTOP: {
int i;
- ptrdiff_t moved;
+ TEBCdata *newTD;
+ ptrdiff_t oldCatchTopOff, oldTosPtrOff;
/*
* Make sure that the element at stackTop is a list; if not, just
@@ -2945,7 +2730,7 @@ TEBCresume(
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(objPtr)));
- if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -2964,19 +2749,21 @@ TEBCresume(
+ codePtr->maxStackDepth /* Beyond the original max */
- CURR_DEPTH; /* Relative to where we are */
DECACHE_STACK_INFO();
- moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- - (Tcl_Obj **) TD;
- if (moved) {
+ oldCatchTopOff = catchTop - initCatchTop;
+ oldTosPtrOff = tosPtr - initTosPtr;
+ newTD = (TEBCdata *)
+ GrowEvaluationStack(iPtr->execEnvPtr, length, 1);
+ if (newTD != TD) {
/*
* 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.
*/
- TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+ TD = newTD;
- catchTop += moved;
- tosPtr += moved;
+ catchTop = initCatchTop + oldCatchTopOff;
+ tosPtr = initTosPtr + oldTosPtrOff;
}
}
@@ -3028,7 +2815,7 @@ TEBCresume(
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
+ objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
@@ -3064,8 +2851,8 @@ TEBCresume(
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call ", objc));
} else {
- fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels,
+ (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -3197,8 +2984,8 @@ TEBCresume(
TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
} else {
fprintf(stdout,
- "%d: (%u) invoking (using implementation %s) ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
O2S(objPtr));
}
for (i = 0; i < objc; i++) {
@@ -3240,7 +3027,7 @@ TEBCresume(
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
@@ -3400,7 +3187,8 @@ TEBCresume(
*/
{
- int storeFlags, len;
+ int storeFlags;
+ int len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3651,7 +3439,7 @@ TEBCresume(
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3677,7 +3465,7 @@ TEBCresume(
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3719,7 +3507,7 @@ TEBCresume(
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
- if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -3730,7 +3518,7 @@ TEBCresume(
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
- if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
+ if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3740,7 +3528,7 @@ TEBCresume(
lappendList:
opnd = -1;
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3778,7 +3566,7 @@ TEBCresume(
if (!objResultPtr) {
valueToAssign = valuePtr;
- } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
+ } else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
@@ -3788,7 +3576,7 @@ TEBCresume(
} else {
valueToAssign = objResultPtr;
}
- if (Tcl_ListObjReplace(interp, valueToAssign, len, 0,
+ if (TclListObjAppendElements(interp, valueToAssign,
objc, objv) != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(valueToAssign);
@@ -3826,9 +3614,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
-#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3922,14 +3708,14 @@ TEBCresume(
}
if (TclIsVarDirectModifyable(varPtr)) {
- ClientData ptr;
+ void *ptr;
int type;
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
- if (type == TCL_NUMBER_LONG) {
- long augend = *((const long *)ptr);
- long sum = (long)((unsigned long)augend + (unsigned long)increment);
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt augend = *((const Tcl_WideInt *)ptr);
+ Tcl_WideInt sum = (Tcl_WideInt)((Tcl_WideUInt)augend + (Tcl_WideUInt)increment);
/*
* Overflow when (augend and sum have different sign) and
@@ -3941,22 +3727,21 @@ TEBCresume(
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
- TclNewLongObj(objResultPtr, sum);
+ TclNewIntObj(objResultPtr, sum);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
- TclSetLongObj(objPtr, sum);
+ TclSetIntObj(objPtr, sum);
}
goto doneIncr;
}
-#ifndef TCL_WIDE_INT_IS_LONG
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);
+ TclNewIntObj(objResultPtr, w + increment);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
@@ -3967,44 +3752,10 @@ TEBCresume(
* use macro form that doesn't range test again.
*/
- TclSetWideIntObj(objPtr, w+increment);
+ TclSetIntObj(objPtr, w+increment);
}
goto doneIncr;
-#endif
- } /* end if (type == TCL_NUMBER_LONG) */
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt sum;
-
- w = *((const Tcl_WideInt *) ptr);
- sum = (Tcl_WideInt)((Tcl_WideUInt)w + (Tcl_WideUInt)increment);
-
- /*
- * Check for overflow.
- */
-
- 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);
- Tcl_IncrRefCount(objResultPtr);
- varPtr->value.objPtr = objResultPtr;
- } else {
- objResultPtr = objPtr;
-
- /*
- * We *do not* know the sum value is outside the
- * long range (wide + long can yield long); use
- * the function call that checks range.
- */
-
- Tcl_SetWideIntObj(objPtr, sum);
- }
- goto doneIncr;
- }
- }
-#endif
+ } /* end if (type == TCL_NUMBER_INT) */
}
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -4014,7 +3765,7 @@ TEBCresume(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
TRACE_ERROR(interp);
@@ -4028,7 +3779,7 @@ TEBCresume(
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
@@ -4413,10 +4164,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr,
- TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_APPEND(("done\n"));
} else {
@@ -4560,15 +4308,15 @@ TEBCresume(
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned)(pc + opnd - codePtr->codeStart)));
+ TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd,
+ (size_t)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
break;
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned)(pc + opnd - codePtr->codeStart)));
+ TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd,
+ (size_t)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
{
@@ -4610,8 +4358,8 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
- TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr),
+ (size_t)(pc + jmpOffset[1] - codePtr->codeStart)));
} else {
TRACE_APPEND(("%.20s true\n", O2S(valuePtr)));
}
@@ -4619,8 +4367,8 @@ TEBCresume(
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
TRACE_APPEND(("%.20s false\n", O2S(valuePtr)));
} else {
- TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
- (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
+ TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr),
+ (size_t)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -4644,8 +4392,8 @@ TEBCresume(
if (hPtr != NULL) {
int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
- TRACE_APPEND(("found in table, new pc %u\n",
- (unsigned)(pc - codePtr->codeStart + jumpOffset)));
+ TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n",
+ (size_t)(pc - codePtr->codeStart + jumpOffset)));
NEXT_INST_F(jumpOffset, 1, 0);
} else {
TRACE_APPEND(("not found in table\n"));
@@ -4721,7 +4469,7 @@ TEBCresume(
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
@@ -4781,6 +4529,18 @@ TEBCresume(
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
+ goto instOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+
+ TclNewObj(objResultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
+ if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(objResultPtr);
+ instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
@@ -4790,12 +4550,6 @@ TEBCresume(
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
- origCmd = TclGetOriginalCommand(cmd);
- if (origCmd == NULL) {
- origCmd = cmd;
- }
- TclNewObj(objResultPtr);
- Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
@@ -4824,7 +4578,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
@@ -4852,7 +4606,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
@@ -4884,9 +4638,9 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ",
iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
+ (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -4910,7 +4664,7 @@ TEBCresume(
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
- for (i=contextPtr->index ; i>=0 ; i--) {
+ for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
miPtr = contextPtr->callPtr->chain + i;
if (miPtr->isFilter
|| miPtr->mPtr->declaringClassPtr != classPtr) {
@@ -4951,7 +4705,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
@@ -4986,8 +4740,8 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -5037,7 +4791,11 @@ TEBCresume(
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
@@ -5079,8 +4837,8 @@ TEBCresume(
*/
{
- int index, numIndices, fromIdx, toIdx;
- int nocase, match, length2, cflags, s1len, s2len;
+ int numIndices, nocase, match, cflags;
+ int length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
@@ -5096,7 +4854,7 @@ TEBCresume(
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
- if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, OBJ_AT_TOS, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5109,21 +4867,48 @@ TEBCresume(
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+ if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
+ if (objResultPtr == NULL) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ Tcl_IncrRefCount(objResultPtr); // reference held here
+ goto lindexDone;
+ }
+
/*
* Extract the desired list element.
*/
- if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
- && (value2Ptr->typePtr != &tclListType)
- && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
- &index) == TCL_OK)) {
- TclDecrRefCount(value2Ptr);
- tosPtr--;
- pcAdjustment = 1;
- goto lindexFastPath;
+ if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
+ && !TclHasInternalRep(value2Ptr, &tclListType)) {
+ int code;
+
+ DECACHE_STACK_INFO();
+ code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index);
+ CACHE_STACK_INFO();
+ if (code == TCL_OK) {
+ TclDecrRefCount(value2Ptr);
+ tosPtr--;
+ pcAdjustment = 1;
+ goto lindexFastPath;
+ }
+ Tcl_ResetResult(interp);
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+
+ lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -5147,12 +4932,35 @@ TEBCresume(
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+
+ /* Decode end-offset index values. */
+
+ index = TclIndexDecode(opnd, length-1);
+
+ /* Compute value @ index */
+ if (index >= 0 && index < length) {
+ objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
+ if (objResultPtr == NULL) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ } else {
+ TclNewObj(objResultPtr);
+ }
+ pcAdjustment = 5;
+ goto lindexFastPath2;
+ }
+
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5169,6 +4977,8 @@ TEBCresume(
TclNewObj(objResultPtr);
}
+ lindexFastPath2:
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -5287,11 +5097,11 @@ TEBCresume(
TclGetInt4AtPtr(pc+5)));
/*
- * Get the contents of the list, making sure that it really is a list
+ * Get the length of the list, making sure that it really is a list
* in the process.
*/
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjLengthM(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5319,17 +5129,11 @@ TEBCresume(
/* Decode index value operands. */
- /*
- assert ( toIdx != TCL_INDEX_AFTER);
- *
- * Extra safety for legacy bytecodes:
- */
- if (toIdx == TCL_INDEX_AFTER) {
- toIdx = TCL_INDEX_END;
- }
-
- if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
- goto emptyList;
+ if (toIdx == TCL_INDEX_NONE) {
+ emptyList:
+ TclNewObj(objResultPtr);
+ TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
+ NEXT_INST_F(9, 1, 1);
}
toIdx = TclIndexDecode(toIdx, objc - 1);
if (toIdx < 0) {
@@ -5340,36 +5144,24 @@ TEBCresume(
assert ( toIdx >= 0 && toIdx < objc);
/*
- assert ( fromIdx != TCL_INDEX_BEFORE );
+ assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (fromIdx == TCL_INDEX_BEFORE) {
+ if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, objc - 1);
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (fromIdx <= toIdx) {
- /* Construct the subsquence list */
- /* unshared optimization */
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
- } else {
- if (toIdx != objc - 1) {
- Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
- 0, NULL);
- }
- Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
- TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
- NEXT_INST_F(9, 0, 0);
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx);
+ if (objResultPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
} else {
- emptyList:
- TclNewObj(objResultPtr);
+ objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
}
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
@@ -5382,7 +5174,7 @@ TEBCresume(
s1 = TclGetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
- if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5390,13 +5182,17 @@ TEBCresume(
if (length > 0) {
int i = 0;
Tcl_Obj *o;
-
+ int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType);
/*
* An empty list doesn't match anything.
*/
do {
- Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
+ if (isArithSeries) {
+ o = TclArithSeriesObjIndex(NULL, value2Ptr, i);
+ } else {
+ Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
+ }
if (o != NULL) {
s2 = TclGetStringFromObj(o, &s2len);
} else {
@@ -5406,6 +5202,9 @@ TEBCresume(
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
+ if (isArithSeries) {
+ TclDecrRefCount(o);
+ }
i++;
} while (i < length && match == 0);
}
@@ -5447,15 +5246,109 @@ TEBCresume(
NEXT_INST_F(1, 1, 0);
}
- /*
- * End of INST_LIST and related instructions.
- * -----------------------------------------------------------------
- * Start of string-related instructions.
- */
+ case INST_LREPLACE4:
+ {
+ int numToDelete, numNewElems, end_indicator;
+ int haveSecondIndex, flags;
+ Tcl_Obj *fromIdxObj, *toIdxObj;
+ opnd = TclGetInt4AtPtr(pc + 1);
+ flags = TclGetInt1AtPtr(pc + 5);
+
+ /* Stack: ... listobj index1 ?index2? new1 ... newN */
+ valuePtr = OBJ_AT_DEPTH(opnd-1);
+
+ /* haveSecondIndex==0 => pure insert */
+ haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0;
+ numNewElems = opnd - 2 - haveSecondIndex;
+
+ /* end_indicator==1 => "end" is last element's index, 0=>index beyond */
+ end_indicator = (flags & TCL_LREPLACE4_END_IS_LAST) != 0;
+ fromIdxObj = OBJ_AT_DEPTH(opnd - 2);
+ toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(opnd - 3) : NULL;
+ if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+
+ DECACHE_STACK_INFO();
+
+ if (TclGetIntForIndexM(
+ interp, fromIdxObj, length - end_indicator, &fromIdx)
+ != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (fromIdx == TCL_INDEX_NONE) {
+ fromIdx = 0;
+ }
+ else if (fromIdx > length) {
+ fromIdx = length;
+ }
+ numToDelete = 0;
+ if (toIdxObj) {
+ if (TclGetIntForIndexM(
+ interp, toIdxObj, length - end_indicator, &toIdx)
+ != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (toIdx > length) {
+ toIdx = length;
+ }
+ if (toIdx >= fromIdx) {
+ numToDelete = toIdx - fromIdx + 1;
+ }
+ }
+
+ CACHE_STACK_INFO();
+
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjReplace(interp,
+ objResultPtr,
+ fromIdx,
+ numToDelete,
+ numNewElems,
+ &OBJ_AT_DEPTH(numNewElems - 1))
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ Tcl_DecrRefCount(objResultPtr);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_V(6, opnd, 1);
+ }
+ else {
+ if (Tcl_ListObjReplace(interp,
+ valuePtr,
+ fromIdx,
+ numToDelete,
+ numNewElems,
+ &OBJ_AT_DEPTH(numNewElems - 1))
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_V(6, opnd - 1, 0);
+ }
+ }
+
+ /*
+ * End of INST_LIST and related instructions.
+ * -----------------------------------------------------------------
+ * Start of string-related instructions.
+ */
case INST_STR_EQ:
case INST_STR_NEQ: /* String (in)equality check */
case INST_STR_CMP: /* String compare. */
+ case INST_STR_LT:
+ case INST_STR_GT:
+ case INST_STR_LE:
+ case INST_STR_GE:
stringCompare:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
@@ -5486,15 +5379,19 @@ TEBCresume(
match = (match != 0);
break;
case INST_LT:
+ case INST_STR_LT:
match = (match < 0);
break;
case INST_GT:
+ case INST_STR_GT:
match = (match > 0);
break;
case INST_LE:
+ case INST_STR_LE:
match = (match <= 0);
break;
case INST_GE:
+ case INST_STR_GE:
match = (match >= 0);
break;
}
@@ -5506,7 +5403,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5524,7 +5421,7 @@ TEBCresume(
} else {
length = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5541,7 +5438,7 @@ TEBCresume(
} else {
length = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5558,7 +5455,7 @@ TEBCresume(
} else {
length = Tcl_UtfToTitle(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5572,26 +5469,41 @@ TEBCresume(
* Get char length to calulate what 'end' means.
*/
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
if ((index < 0) || (index >= length)) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
- Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
+ TclGetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
- char buf[8] = "";
- int ch = TclGetUCS4(valuePtr, index);
+ char buf[4] = "";
+ int ch = TclGetUniChar(valuePtr, index);
- length = TclUCS4ToUtf(ch, buf);
- objResultPtr = Tcl_NewStringObj(buf, length);
+ /*
+ * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
+ * but creating the object as a string seems to be faster in
+ * practical use.
+ */
+ if (ch == -1) {
+ TclNewObj(objResultPtr);
+ } else {
+ length = Tcl_UniCharToUtf(ch, buf);
+ if ((ch >= 0xD800) && (length < 3)) {
+ length += Tcl_UniCharToUtf(-1, buf + length);
+ }
+ objResultPtr = Tcl_NewStringObj(buf, length);
+ }
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
@@ -5600,25 +5512,27 @@ TEBCresume(
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
- length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
+ length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1;
+
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
- &fromIdx) != TCL_OK
- || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ &fromIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (toIdx >= length) {
- toIdx = length;
- }
- if (toIdx >= fromIdx) {
- objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
- } else {
+ if (toIdx < 0) {
TclNewObj(objResultPtr);
+ } else {
+ objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(1, 3, 1);
@@ -5627,7 +5541,7 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
/* Every range of an empty value is an empty value */
@@ -5639,50 +5553,28 @@ TEBCresume(
/* Decode index operands. */
/*
- assert ( toIdx != TCL_INDEX_BEFORE );
- assert ( toIdx != TCL_INDEX_AFTER);
- *
- * Extra safety for legacy bytecodes:
- */
- if (toIdx == TCL_INDEX_BEFORE) {
- goto emptyRange;
- }
- if (toIdx == TCL_INDEX_AFTER) {
- toIdx = TCL_INDEX_END;
- }
-
- toIdx = TclIndexDecode(toIdx, length - 1);
- if (toIdx < 0) {
- goto emptyRange;
- } else if (toIdx >= length) {
- toIdx = length - 1;
- }
-
- assert ( toIdx >= 0 && toIdx < length );
-
- /*
- assert ( fromIdx != TCL_INDEX_BEFORE );
- assert ( fromIdx != TCL_INDEX_AFTER);
+ assert ( toIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (fromIdx == TCL_INDEX_BEFORE) {
- fromIdx = TCL_INDEX_START;
- }
- if (fromIdx == TCL_INDEX_AFTER) {
- goto emptyRange;
- }
-
- fromIdx = TclIndexDecode(fromIdx, length - 1);
- if (fromIdx < 0) {
- fromIdx = 0;
- }
-
- if (fromIdx <= toIdx) {
- objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
- } else {
- emptyRange:
+ if (toIdx == TCL_INDEX_NONE) {
TclNewObj(objResultPtr);
+ } else {
+ toIdx = TclIndexDecode(toIdx, length - 1);
+ /*
+ assert ( fromIdx != TCL_INDEX_NONE );
+ *
+ * Extra safety for legacy bytecodes:
+ */
+ if (fromIdx == TCL_INDEX_NONE) {
+ fromIdx = TCL_INDEX_START;
+ }
+ fromIdx = TclIndexDecode(fromIdx, length - 1);
+ if (toIdx < 0) {
+ TclNewObj(objResultPtr);
+ } else {
+ objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx);
+ }
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
@@ -5695,17 +5587,20 @@ TEBCresume(
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
- endIdx = Tcl_GetCharLength(valuePtr) - 1;
+ endIdx = TclGetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
&toIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
@@ -5734,82 +5629,9 @@ TEBCresume(
NEXT_INST_F(1, 0, 0);
}
- length3 = Tcl_GetCharLength(value3Ptr);
-
- /*
- * See if we can splice in place. This happens when the number of
- * characters being replaced is the same as the number of characters
- * in the string to be inserted.
- */
+ objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
+ toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
- if (length3 - 1 == toIdx - fromIdx) {
- unsigned char *bytes1, *bytes2;
-
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_DuplicateObj(valuePtr);
- } else {
- objResultPtr = valuePtr;
- }
- if (TclIsPureByteArray(objResultPtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- }
- Tcl_InvalidateStringRep(objResultPtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- if (objResultPtr == valuePtr) {
- NEXT_INST_F(1, 0, 0);
- } else {
- NEXT_INST_F(1, 1, 1);
- }
- }
-
- /*
- * Get the unicode representation; this is where we guarantee to lose
- * bytearrays.
- */
-
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
- length--;
-
- /*
- * Remove substring using copying.
- */
-
- objResultPtr = NULL;
- if (fromIdx > 0) {
- objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
- }
- if (length3 > 0) {
- if (objResultPtr) {
- Tcl_AppendObjToObj(objResultPtr, value3Ptr);
- } else if (Tcl_IsShared(value3Ptr)) {
- objResultPtr = Tcl_DuplicateObj(value3Ptr);
- } else {
- objResultPtr = value3Ptr;
- }
- }
- if (toIdx < length) {
- if (objResultPtr) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
- length - toIdx);
- } else {
- objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
- length - toIdx);
- }
- }
- if (objResultPtr == NULL) {
- /* This has to be the case [string replace $s 0 end {}] */
- /* which has result {} which is same as value3Ptr. */
- objResultPtr = value3Ptr;
- }
if (objResultPtr == value3Ptr) {
/* See [Bug 82e7f67325] */
TclDecrRefCount(OBJ_AT_TOS);
@@ -5832,12 +5654,12 @@ TEBCresume(
objResultPtr = value3Ptr;
goto doneStringMap;
}
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ ustring1 = TclGetUnicodeFromObj_(valuePtr, &length);
if (length == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
}
- ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ ustring2 = TclGetUnicodeFromObj_(value2Ptr, &length2);
if (length2 > length || length2 == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
@@ -5849,9 +5671,9 @@ TEBCresume(
}
goto doneStringMap;
}
- ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
+ ustring3 = TclGetUnicodeFromObj_(value3Ptr, &length3);
- objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ objResultPtr = TclNewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + length;
for (; ustring1 < end; ustring1++) {
@@ -5861,14 +5683,14 @@ TEBCresume(
memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
== 0)) {
if (p != ustring1) {
- Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
- Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
+ TclAppendUnicodeToObj(objResultPtr, ustring3, length3);
}
}
if (p != ustring1) {
@@ -5876,7 +5698,7 @@ TEBCresume(
* Put the rest of the unmapped chars onto result.
*/
- Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+ TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p);
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
@@ -5884,45 +5706,17 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- end = ustring1 + length - length2 + 1;
- for (p=ustring1 ; p<end ; p++) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
- TRACE(("%.20s %.20s => %d\n",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
-
- TRACE(("%.20s %.20s => %d\n",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+ objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
- TclNewIntObj(objResultPtr, match);
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -5930,7 +5724,7 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
O2S(valuePtr)));
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ ustring1 = TclGetUnicodeFromObj_(valuePtr, &length);
match = 1;
if (length > 0) {
int ch;
@@ -5957,12 +5751,12 @@ TEBCresume(
* both.
*/
- if ((valuePtr->typePtr == &tclStringType)
- || (value2Ptr->typePtr == &tclStringType)) {
+ if (TclHasInternalRep(valuePtr, &tclUniCharStringType)
+ || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
Tcl_UniChar *ustring1, *ustring2;
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
- ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ ustring1 = TclGetUnicodeFromObj_(valuePtr, &length);
+ ustring2 = TclGetUnicodeFromObj_(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length, ustring2, length2,
nocase);
} else if (TclIsPureByteArray(valuePtr) && !nocase) {
@@ -6090,38 +5884,13 @@ TEBCresume(
*/
{
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
int type1, type2;
- long l1 = 0, l2, lResult;
+ Tcl_WideInt w1, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
- } else if (type1 == TCL_NUMBER_LONG) {
- /* value is between LONG_MIN and LONG_MAX */
- /* [string is integer] is -UINT_MAX to UINT_MAX range */
- int i;
-
- if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if (type1 == TCL_NUMBER_WIDE) {
- /* value is between WIDE_MIN and WIDE_MAX */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
- int i;
- if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
- type1 = TCL_NUMBER_LONG;
- }
-#endif
- } else if (type1 == TCL_NUMBER_BIG) {
- /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
- Tcl_WideInt w;
-
- if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
- }
}
TclNewIntObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
@@ -6166,10 +5935,10 @@ TEBCresume(
compare = MP_EQ;
goto convertComparison;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
- compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
+ compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
} else {
compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
}
@@ -6245,17 +6014,17 @@ TEBCresume(
* Check for common, simple case.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_MOD:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto divideByZero;
- } else if ((l2 == 1) || (l2 == -1)) {
+ } else if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -6264,7 +6033,7 @@ TEBCresume(
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
@@ -6274,26 +6043,26 @@ TEBCresume(
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
} else {
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if ((lResult < 0 || (lResult == 0 &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- (lResult * l2 != l1)) {
- lResult -= 1;
+ if ((wResult < 0 || (wResult == 0 &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ (wResult * w2 != w1)) {
+ wResult -= 1;
}
- lResult = (long)((unsigned long)l1 -
- (unsigned long)l2*(unsigned long)lResult);
- goto longResultOfArithmetic;
+ wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 -
+ (Tcl_WideUInt)w2*(Tcl_WideUInt)wResult);
+ goto wideResultOfArithmetic;
}
break;
case INST_RSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
@@ -6304,7 +6073,7 @@ TEBCresume(
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
@@ -6314,7 +6083,7 @@ TEBCresume(
* Quickly force large right shifts to 0 or -1.
*/
- if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
+ if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) {
/*
* We assume that INT_MAX is much larger than the
* number of bits in a long. This is a pretty safe
@@ -6323,7 +6092,7 @@ TEBCresume(
*/
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (l1 > 0L) {
+ if (w1 > 0L) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
@@ -6336,13 +6105,13 @@ TEBCresume(
* Handle shifts within the native long range.
*/
- lResult = l1 >> ((int) l2);
- goto longResultOfArithmetic;
+ wResult = w1 >> ((int) w2);
+ goto wideResultOfArithmetic;
}
break;
case INST_LSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
@@ -6353,12 +6122,12 @@ TEBCresume(
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l2 > (long) INT_MAX) {
+ } else if (w2 > 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
@@ -6376,17 +6145,17 @@ TEBCresume(
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else {
- int shift = (int) l2;
+ int shift = (int) w2;
/*
* Handle shifts within the native long range.
*/
- if (((size_t) shift < CHAR_BIT*sizeof(long))
- && !((l1>0 ? l1 : ~l1) &
+ if (((size_t)shift < CHAR_BIT*sizeof(long))
+ && !((w1>0 ? w1 : ~w1) &
-(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- lResult = (unsigned long)l1 << shift;
- goto longResultOfArithmetic;
+ wResult = (Tcl_WideUInt)w1 << shift;
+ goto wideResultOfArithmetic;
}
}
@@ -6398,23 +6167,14 @@ TEBCresume(
break;
case INST_BITAND:
- lResult = l1 & l2;
- goto longResultOfArithmetic;
+ wResult = w1 & w2;
+ goto wideResultOfArithmetic;
case INST_BITOR:
- lResult = l1 | l2;
- goto longResultOfArithmetic;
+ wResult = w1 | w2;
+ goto wideResultOfArithmetic;
case INST_BITXOR:
- lResult = l1 ^ l2;
- 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);
+ wResult = w1 ^ w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6497,18 +6257,13 @@ TEBCresume(
* an external function.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- Tcl_WideInt w1, w2, wResult;
-
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_ADD:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -6516,14 +6271,10 @@ TEBCresume(
if (Overflowing(w1, w2, wResult)) {
goto overflow;
}
-#endif
goto wideResultOfArithmetic;
case INST_SUB:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2);
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Must check for overflow. The macro tests for overflows in
* sums by looking at the sign bits. As we have a subtraction
@@ -6537,54 +6288,53 @@ TEBCresume(
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
-#endif
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
+ TclNewIntObj(objResultPtr, wResult);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
- Tcl_SetWideIntObj(valuePtr, wResult);
+ TclSetIntObj(valuePtr, wResult);
TRACE(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
break;
case INST_DIV:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- } else if ((l1 == LONG_MIN) && (l2 == -1)) {
+ } else if ((w1 == WIDE_MIN) && (w2 == -1)) {
/*
- * Can't represent (-LONG_MIN) as a long.
+ * Can't represent (-WIDE_MIN) as a Tcl_WideInt.
*/
goto overflow;
}
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if (((lResult < 0) || ((lResult == 0) &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- ((lResult * l2) != l1)) {
- lResult -= 1;
+ if (((wResult < 0) || ((wResult == 0) &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ ((wResult * w2) != w1)) {
+ wResult -= 1;
}
- goto longResultOfArithmetic;
+ goto wideResultOfArithmetic;
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;
+ if (((sizeof(Tcl_WideInt) >= 2*sizeof(int))
+ && (w1 <= INT_MAX) && (w1 >= INT_MIN)
+ && (w2 <= INT_MAX) && (w2 >= INT_MIN))
+ || ((sizeof(Tcl_WideInt) >= 2*sizeof(short))
+ && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN)
+ && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) {
+ wResult = w1 * w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6606,6 +6356,9 @@ TEBCresume(
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
TRACE_ERROR(interp);
goto gotError;
+ } else if (objResultPtr == OUT_OF_MEMORY) {
+ TRACE_APPEND(("OUT OF MEMORY\n"));
+ goto outOfMemory;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
@@ -6651,14 +6404,14 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *) ptr1);
+ if (type1 == TCL_NUMBER_INT) {
+ w1 = *((const Tcl_WideInt *) ptr1);
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, ~l1);
+ TclNewIntObj(objResultPtr, ~w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, ~l1);
+ TclSetIntObj(valuePtr, ~w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6689,15 +6442,15 @@ TEBCresume(
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
break;
- case TCL_NUMBER_LONG:
- l1 = *((const long *) ptr1);
- if (l1 != LONG_MIN) {
+ case TCL_NUMBER_INT:
+ w1 = *((const Tcl_WideInt *) ptr1);
+ if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, -l1);
+ TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, -l1);
+ TclSetIntObj(valuePtr, -w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6806,7 +6559,7 @@ TEBCresume(
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
- if (valuePtr->typePtr == &tclBooleanType) {
+ if (TclHasInternalRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
@@ -6843,7 +6596,8 @@ TEBCresume(
Var *iterVarPtr, *listVarPtr;
Tcl_Obj *oldValuePtr, *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterNum, listTmpIndex, listLen, numVars;
+ int numLists, listTmpIndex, listLen, numVars;
+ size_t iterNum;
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
@@ -6854,16 +6608,16 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
- TclNewLongObj(iterVarPtr->value.objPtr, -1);
+ TclNewIntObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
- TclSetLongObj(oldValuePtr, -1);
+ TclSetIntObj(oldValuePtr, -1);
}
TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
@@ -6888,7 +6642,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
@@ -6897,8 +6651,8 @@ TEBCresume(
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
- iterNum = valuePtr->internalRep.longValue + 1;
- TclSetLongObj(valuePtr, iterNum);
+ iterNum = (size_t)valuePtr->internalRep.wideValue + 1;
+ TclSetIntObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should stop the
@@ -6913,12 +6667,12 @@ TEBCresume(
listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
- if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
- if (listLen > iterNum * numVars) {
+ if ((size_t)listLen > iterNum * numVars) {
continueLoop = 1;
}
listTmpIndex++;
@@ -6941,7 +6695,7 @@ TEBCresume(
listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -6984,7 +6738,7 @@ TEBCresume(
listTmpIndex++;
}
}
- TRACE_APPEND(("%d lists, iter %d, %s loop\n",
+ TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n",
numLists, iterNum, (continueLoop? "continue" : "exit")));
/*
@@ -7005,8 +6759,9 @@ TEBCresume(
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterMax, listLen, numVars;
- int iterTmp, iterNum, listTmpDepth;
+ int numLists, listLen, numVars;
+ int listTmpDepth;
+ size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
@@ -7017,7 +6772,7 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
@@ -7031,7 +6786,7 @@ TEBCresume(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
@@ -7057,8 +6812,8 @@ TEBCresume(
*/
TclNewObj(tmpPtr);
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
- tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
+ tmpPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax;
PUSH_OBJECT(tmpPtr); /* iterCounts object */
/*
@@ -7085,13 +6840,13 @@ TEBCresume(
*/
tmpPtr = OBJ_AT_TOS;
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> "));
tmpPtr = OBJ_AT_DEPTH(1);
- iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
- iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
+ iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1;
+ iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2;
/*
* If some list still has a remaining list element iterate one more
@@ -7103,7 +6858,7 @@ TEBCresume(
* Set the variables and jump back to run the body
*/
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
+ tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
@@ -7112,7 +6867,7 @@ TEBCresume(
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -7169,7 +6924,7 @@ TEBCresume(
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> loop terminated\n"));
NEXT_INST_V(1, numLists+2, 0);
@@ -7186,7 +6941,7 @@ TEBCresume(
*/
tmpPtr = OBJ_AT_DEPTH(1);
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
@@ -7203,10 +6958,10 @@ TEBCresume(
* stack.
*/
- *(++catchTop) = CURR_DEPTH;
- TRACE(("%u => catchTop=%d, stackTop=%d\n",
- TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
- (int) CURR_DEPTH));
+ *(++catchTop) = (Tcl_Obj *)UINT2PTR(CURR_DEPTH);
+ TRACE(("%u => catchTop=%" TCL_Z_MODIFIER "u, stackTop=%" TCL_Z_MODIFIER "u\n",
+ TclGetUInt4AtPtr(pc+1), (size_t)(catchTop - initCatchTop - 1),
+ CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
@@ -7216,7 +6971,7 @@ TEBCresume(
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_OK;
- TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
+ TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
break;
@@ -7270,7 +7025,8 @@ TEBCresume(
*/
{
- int opnd2, allocateDict, done, i, allocdict;
+ int opnd2, allocateDict, done, allocdict;
+ int i;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
@@ -7286,56 +7042,25 @@ TEBCresume(
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
+ break;
- case INST_DICT_GET:
case INST_DICT_EXISTS: {
- Tcl_Interp *interp2 = interp;
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
- if (*pc == INST_DICT_EXISTS) {
- interp2 = NULL;
- }
if (opnd > 1) {
- dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
- &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
- if (dictPtr == NULL) {
- if (*pc == INST_DICT_EXISTS) {
- found = 0;
- goto afterDictExists;
- }
- TRACE_WITH_OBJ((
- "ERROR tracing dictionary path into \"%.30s\": ",
- O2S(OBJ_AT_DEPTH(opnd))),
- Tcl_GetObjResult(interp));
- goto gotError;
+ dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS);
+ if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) {
+ found = 0;
+ goto afterDictExists;
}
}
- if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
+ if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
- if (*pc == INST_DICT_EXISTS) {
- found = (objResultPtr ? 1 : 0);
- goto afterDictExists;
- }
- if (!objResultPtr) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "key \"%s\" not known in dictionary",
- TclGetString(OBJ_AT_TOS)));
- DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
- TclGetString(OBJ_AT_TOS), NULL);
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
- }
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
- } else if (*pc != INST_DICT_EXISTS) {
- TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
- O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
- goto gotError;
+ found = (objResultPtr ? 1 : 0);
} else {
found = 0;
}
@@ -7351,6 +7076,68 @@ TEBCresume(
JUMP_PEEPHOLE_V(found, 5, opnd+1);
}
+ case INST_DICT_GET:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = OBJ_AT_DEPTH(opnd);
+ if (opnd > 1) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ TRACE_WITH_OBJ((
+ "ERROR tracing dictionary path into \"%.30s\": ",
+ O2S(OBJ_AT_DEPTH(opnd))),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ }
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
+ &objResultPtr) != TCL_OK) {
+ TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ if (!objResultPtr) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(OBJ_AT_TOS), NULL);
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ case INST_DICT_GET_DEF:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = OBJ_AT_DEPTH(opnd+1);
+ if (opnd > 1) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS);
+ if (dictPtr == NULL) {
+ TRACE_WITH_OBJ((
+ "ERROR tracing dictionary path into \"%.30s\": ",
+ O2S(OBJ_AT_DEPTH(opnd+1))),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ } else if (dictPtr == DICT_PATH_NON_EXISTENT) {
+ goto dictGetDefUseDefault;
+ }
+ }
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
+ &objResultPtr) != TCL_OK) {
+ TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (!objResultPtr) {
+ dictGetDefUseDefault:
+ objResultPtr = OBJ_AT_TOS;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+2, 1);
case INST_DICT_SET:
case INST_DICT_UNSET:
@@ -7395,7 +7182,7 @@ TEBCresume(
break;
}
if (valuePtr == NULL) {
- Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd));
} else {
TclNewIntObj(value2Ptr, opnd);
Tcl_IncrRefCount(value2Ptr);
@@ -7602,7 +7389,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
- searchPtr = ckalloc(sizeof(Tcl_DictSearch));
+ searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
@@ -7617,13 +7404,16 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewObj(statePtr);
- statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ {
+ Tcl_ObjInternalRep ir;
+ TclNewObj(statePtr);
+ ir.twoPtrValue.ptr1 = searchPtr;
+ ir.twoPtrValue.ptr2 = dictPtr;
+ Tcl_StoreInternalRep(statePtr, &dictIteratorType, &ir);
+ }
varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
+ if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) {
Tcl_Panic("mis-issued dictFirst!");
}
TclDecrRefCount(varPtr->value.objPtr);
@@ -7636,11 +7426,17 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
- if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
- Tcl_Panic("mis-issued dictNext!");
+ {
+ const Tcl_ObjInternalRep *irPtr;
+
+ if (statePtr &&
+ (irPtr = TclFetchInternalRep(statePtr, &dictIteratorType))) {
+ searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
+ Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
+ } else {
+ Tcl_Panic("mis-issued dictNext!");
+ }
}
- searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
- Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:
if (done) {
TclNewObj(emptyPtr);
@@ -7667,7 +7463,7 @@ TEBCresume(
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
- duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
+ duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -7684,7 +7480,7 @@ TEBCresume(
}
}
Tcl_IncrRefCount(dictPtr);
- if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
+ if (TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -7727,7 +7523,7 @@ TEBCresume(
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
- duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
+ duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -7744,7 +7540,7 @@ TEBCresume(
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
- || TclListObjGetElements(interp, OBJ_AT_TOS, &length,
+ || TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -7803,7 +7599,7 @@ TEBCresume(
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -7821,7 +7617,7 @@ TEBCresume(
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
@@ -7852,7 +7648,7 @@ TEBCresume(
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -7881,30 +7677,30 @@ TEBCresume(
{ /* Read the wall clock */
Tcl_WideInt wval;
Tcl_Time now;
- switch(TclGetUInt1AtPtr(pc+1)) {
+ switch (TclGetUInt1AtPtr(pc+1)) {
case 0: /* clicks */
#ifdef TCL_WIDE_CLICKS
wval = TclpGetWideClicks();
#else
- wval = (Tcl_WideInt) TclpGetClicks();
+ wval = (Tcl_WideInt)TclpGetClicks();
#endif
break;
case 1: /* microseconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec * 1000000 + now.usec;
+ wval = (Tcl_WideInt)now.sec * 1000000 + now.usec;
break;
case 2: /* milliseconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000;
+ wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000;
break;
case 3: /* seconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec;
+ wval = (Tcl_WideInt)now.sec;
break;
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
- objResultPtr = Tcl_NewWideIntObj(wval);
+ TclNewIntObj(objResultPtr, wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
@@ -7978,7 +7774,7 @@ TEBCresume(
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
}
- if (rangePtr->continueOffset == -1) {
+ if (rangePtr->continueOffset == TCL_INDEX_NONE) {
TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
StringForResultCode(result)));
goto checkForCatch;
@@ -8016,6 +7812,13 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
+ outOfMemory:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
@@ -8067,8 +7870,8 @@ TEBCresume(
while (auxObjList) {
if ((catchTop != initCatchTop)
- && (*catchTop > (ptrdiff_t)
- auxObjList->internalRep.twoPtrValue.ptr2)) {
+ && (PTR2UINT(*catchTop) >
+ PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2))) {
break;
}
POP_TAUX_OBJ();
@@ -8143,16 +7946,16 @@ TEBCresume(
*/
processCatch:
- while (CURR_DEPTH > *catchTop) {
+ while (CURR_DEPTH > PTR2UINT(*catchTop)) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
- fprintf(stdout, " ... found catch at %d, catchTop=%d, "
- "unwound to %ld, new pc %u\n",
- rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
- (long) *catchTop, (unsigned) rangePtr->catchOffset);
+ fprintf(stdout, " ... found catch at %d, catchTop=%" TCL_Z_MODIFIER "u, "
+ "unwound to %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
+ rangePtr->codeOffset, (size_t)(catchTop - initCatchTop - 1),
+ PTR2UINT(*catchTop), (size_t)rangePtr->catchOffset);
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
@@ -8188,19 +7991,17 @@ TEBCresume(
if (tosPtr < initTosPtr) {
fprintf(stderr,
- "\nTclNRExecuteByteCode: abnormal return at pc %u: "
- "stack top %d < entry stack top %d\n",
- (unsigned)(pc - codePtr->codeStart),
- (unsigned) CURR_DEPTH, (unsigned) 0);
+ "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: "
+ "stack top %" TCL_Z_MODIFIER "u < entry stack top %d\n",
+ (size_t)(pc - codePtr->codeStart),
+ CURR_DEPTH, 0);
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
CLANG_ASSERT(bcFramePtr);
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
@@ -8258,18 +8059,18 @@ TEBCresume(
static int
FinalizeOONext(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -8284,18 +8085,18 @@ FinalizeOONext(
static int
FinalizeOONextFilter(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -8309,47 +8110,10 @@ FinalizeOONextFilter(
}
/*
- * LongPwrSmallExpon -- , WidePwrSmallExpon --
+ * WidePwrSmallExpon --
*
- * Helpers to calculate small powers of integers whose result is long or wide.
+ * Helper to calculate small powers of integers whose result is wide.
*/
-#if (LONG_MAX == 0x7FFFFFFF)
-static inline long
-LongPwrSmallExpon(long l1, long exponent) {
-
- long lResult;
-
- lResult = l1 * l1; /* b**2 */
- switch (exponent) {
- 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;
- }
- return lResult;
-}
-#endif
static inline Tcl_WideInt
WidePwrSmallExpon(Tcl_WideInt w1, long exponent) {
@@ -8463,19 +8227,11 @@ ExecuteExtendedBinaryMathOp(
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)); \
+ TclSetIntObj(valuePtr, (w)); \
return NULL; \
}
#define BIG_RESULT(b) \
@@ -8495,14 +8251,14 @@ ExecuteExtendedBinaryMathOp(
}
int type1, type2;
- ClientData ptr1, ptr2;
+ void *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, zero;
long shift;
+ mp_err err;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
@@ -8511,13 +8267,13 @@ ExecuteExtendedBinaryMathOp(
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) {
+ w2 = 0; /* silence gcc warning */
+ if (type2 == TCL_NUMBER_INT) {
+ w2 = *((const Tcl_WideInt *)ptr2);
+ if (w2 == 0) {
return DIVIDED_BY_ZERO;
}
- if ((l2 == 1) || (l2 == -1)) {
+ if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -8525,12 +8281,19 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *)ptr1);
- if (type2 != TCL_NUMBER_BIG) {
+
+ if (w1 == 0) {
+ /*
+ * 0 % (non-zero) always yields remainder of 0.
+ */
+
+ return constants[0];
+ }
+ if (type2 == TCL_NUMBER_INT) {
Tcl_WideInt wQuotient, wRemainder;
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+ w2 = *((const Tcl_WideInt *)ptr2);
wQuotient = w1 / w2;
/*
@@ -8538,12 +8301,12 @@ ExecuteExtendedBinaryMathOp(
* 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))))
+ if (((wQuotient < 0)
+ || ((wQuotient == 0)
+ && ((w1 < 0 && w2 > 0)
+ || (w1 > 0 && w2 < 0))))
&& (wQuotient * w2 != w1)) {
- wQuotient -= (Tcl_WideInt) 1;
+ wQuotient -= 1;
}
wRemainder = (Tcl_WideInt)((Tcl_WideUInt)w1 -
(Tcl_WideUInt)w2*(Tcl_WideUInt)wQuotient);
@@ -8553,14 +8316,19 @@ ExecuteExtendedBinaryMathOp(
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
/* TODO: internals intrusion */
- if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) {
+ if ((w1 > ((Tcl_WideInt)0)) ^ !mp_isneg(&big2)) {
/*
* Arguments are opposite sign; remainder is sum.
*/
- TclBNInitBignumFromWideInt(&big1, w1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
+ err = mp_init_i64(&big1, w1);
+ if (err == MP_OKAY) {
+ err = mp_add(&big2, &big1, &big2);
+ mp_clear(&big1);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&big2);
}
@@ -8571,24 +8339,29 @@ ExecuteExtendedBinaryMathOp(
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)) {
+ err = mp_init_multi(&bigResult, &bigRemainder, NULL);
+ if (err == MP_OKAY) {
+ err = mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ }
+ if ((err == MP_OKAY) && !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);
+ if ((mp_sub_d(&bigResult, 1, &bigResult) != MP_OKAY)
+ || (mp_add(&bigRemainder, &big2, &bigRemainder) != MP_OKAY)) {
+ return OUT_OF_MEMORY;
+ }
}
- mp_copy(&bigRemainder, &bigResult);
+ err = mp_copy(&bigRemainder, &bigResult);
mp_clear(&bigRemainder);
mp_clear(&big1);
mp_clear(&big2);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&bigResult);
case INST_LSHIFT:
@@ -8598,17 +8371,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < 0L);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
+ case TCL_NUMBER_INT:
+ invalid = (*((const Tcl_WideInt *)ptr2) < 0);
break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- invalid = (mp_cmp_d(&big2, 0) == MP_LT);
+ invalid = mp_isneg(&big2);
mp_clear(&big2);
break;
default:
@@ -8625,7 +8393,7 @@ ExecuteExtendedBinaryMathOp(
* Zero shifted any number of bits is still zero.
*/
- if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
+ if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 0)) {
return constants[0];
}
@@ -8638,8 +8406,8 @@ ExecuteExtendedBinaryMathOp(
* counterparts, leading to incorrect results.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (long) INT_MAX)) {
+ if ((type2 != TCL_NUMBER_INT)
+ || (*((const Tcl_WideInt *)ptr2) > 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
@@ -8651,15 +8419,15 @@ ExecuteExtendedBinaryMathOp(
"integer value too large to represent", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- shift = (int)(*((const long *)ptr2));
+ shift = (int)(*((const Tcl_WideInt *)ptr2));
/*
* Handle shifts within the native wide range.
*/
- if ((type1 != TCL_NUMBER_BIG)
+ if ((type1 == TCL_NUMBER_INT)
&& ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ w1 = *((const Tcl_WideInt *)ptr1);
if (!((w1>0 ? w1 : ~w1)
& -(((Tcl_WideUInt)1)
<< (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
@@ -8671,8 +8439,8 @@ ExecuteExtendedBinaryMathOp(
* Quickly force large right shifts to 0 or -1.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*(const long *)ptr2 > INT_MAX)) {
+ if ((type2 != TCL_NUMBER_INT)
+ || (*(const Tcl_WideInt *)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
@@ -8682,17 +8450,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
+ case TCL_NUMBER_INT:
+ zero = (*(const Tcl_WideInt *)ptr1 > 0);
break;
-#ifndef TCL_WIDE_INT_IS_LONG
- 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);
+ zero = !mp_isneg(&big1);
mp_clear(&big1);
break;
default:
@@ -8702,35 +8465,38 @@ ExecuteExtendedBinaryMathOp(
if (zero) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
- shift = (int)(*(const long *)ptr2);
+ shift = (int)(*(const Tcl_WideInt *)ptr2);
-#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *(const Tcl_WideInt *)ptr1;
if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
- if (w1 >= (Tcl_WideInt)0) {
+ if (w1 >= 0) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_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_signed_rsh(&big1, shift, &bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
+ if (opcode == INST_LSHIFT) {
+ err = mp_mul_2d(&big1, shift, &bigResult);
+ } else {
+ err = mp_signed_rsh(&big1, shift, &bigResult);
+ }
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
}
mp_clear(&big1);
BIG_RESULT(&bigResult);
@@ -8739,24 +8505,29 @@ ExecuteExtendedBinaryMathOp(
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
- if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
+ if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) {
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
+ err = mp_init(&bigResult);
- switch (opcode) {
- case INST_BITAND:
- mp_and(&big1, &big2, &bigResult);
- break;
+ if (err == MP_OKAY) {
+ switch (opcode) {
+ case INST_BITAND:
+ err = mp_and(&big1, &big2, &bigResult);
+ break;
- case INST_BITOR:
- mp_or(&big1, &big2, &bigResult);
- break;
+ case INST_BITOR:
+ err = mp_or(&big1, &big2, &bigResult);
+ break;
- case INST_BITXOR:
- mp_xor(&big1, &big2, &bigResult);
- break;
+ case INST_BITXOR:
+ err = mp_xor(&big1, &big2, &bigResult);
+ break;
+ }
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
}
mp_clear(&big1);
@@ -8764,46 +8535,24 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
-#ifndef TCL_WIDE_INT_IS_LONG
- 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);
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_BITAND:
- lResult = l1 & l2;
+ wResult = w1 & w2;
break;
case INST_BITOR:
- lResult = l1 | l2;
+ wResult = w1 | w2;
break;
case INST_BITXOR:
- lResult = l1 ^ l2;
+ wResult = w1 ^ w2;
break;
default:
/* Unused, here to silence compiler warning. */
- lResult = 0;
+ wResult = 0;
}
- LONG_RESULT(lResult);
+ WIDE_RESULT(wResult);
case INST_EXPON: {
int oddExponent = 0, negativeExponent = 0;
@@ -8819,96 +8568,57 @@ ExecuteExtendedBinaryMathOp(
dResult = pow(d1, d2);
goto doubleResult;
}
- l1 = l2 = 0;
w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */
- switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *) ptr2);
-#ifndef TCL_WIDE_INT_IS_LONG
- pwrLongExpon:
-#endif
- if (l2 == 0) {
+ if (type2 == TCL_NUMBER_INT) {
+ w2 = *((const Tcl_WideInt *) ptr2);
+ if (w2 == 0) {
/*
* Anything to the zero power is 1.
*/
return constants[1];
- } else if (l2 == 1) {
+ } else if (w2 == 1) {
/*
* Anything to the first power is itself
*/
return NULL;
}
- negativeExponent = (l2 < 0);
- oddExponent = (int) (l2 & 1);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- /* check it fits in long */
- l2 = (long)w2;
- if (w2 == l2) {
- type2 = TCL_NUMBER_LONG;
- goto pwrLongExpon;
- }
+
negativeExponent = (w2 < 0);
- oddExponent = (int) (w2 & (Tcl_WideInt)1);
- break;
-#endif
- case TCL_NUMBER_BIG:
+ oddExponent = (int)w2 & 1;
+ } else {
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_mod_2d(&big2, 1, &big2);
- oddExponent = !mp_iszero(&big2);
+ negativeExponent = mp_isneg(&big2);
+ err = mp_mod_2d(&big2, 1, &big2);
+ oddExponent = (err == MP_OKAY) && !mp_iszero(&big2);
mp_clear(&big2);
- break;
}
- switch (type1) {
- case TCL_NUMBER_LONG:
- l1 = *((const long *)ptr1);
-#ifndef TCL_WIDE_INT_IS_LONG
- pwrLongBase:
-#endif
- switch (l1) {
- case 0:
- /*
- * Zero to a positive power is zero.
- * Zero to a negative power is div by zero error.
- */
+ if (type1 == TCL_NUMBER_INT) {
+ w1 = *((const Tcl_WideInt *)ptr1);
- return (!negativeExponent) ? constants[0] : EXPONENT_OF_ZERO;
- case 1:
- /*
- * 1 to any power is 1.
- */
+ if (negativeExponent) {
+ switch (w1) {
+ case 0:
+ /*
+ * Zero to a negative power is div by zero error.
+ */
- return constants[1];
- case -1:
- if (!negativeExponent) {
- if (!oddExponent) {
- return constants[1];
+ return EXPONENT_OF_ZERO;
+ case -1:
+ if (oddExponent) {
+ WIDE_RESULT(-1);
}
- LONG_RESULT(-1);
- }
- /* negativeExponent */
- if (oddExponent) {
- LONG_RESULT(-1);
+ /* fallthrough */
+ case 1:
+ /*
+ * 1 to any power is 1.
+ */
+
+ return constants[1];
}
- return constants[1];
}
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *) ptr1);
- /* check it fits in long */
- l1 = (long)w1;
- if (w1 == l1) {
- type1 = TCL_NUMBER_LONG;
- goto pwrLongBase;
- }
-#endif
}
if (negativeExponent) {
@@ -8919,119 +8629,77 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
-
- if (type1 == TCL_NUMBER_BIG) {
+ if (type1 != TCL_NUMBER_INT) {
goto overflowExpon;
}
+ switch (w1) {
+ 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];
+ }
+ WIDE_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 type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger than we
+ * range of the long int type. This means any numeric Tcl_Obj value
+ * not using TCL_NUMBER_INT type must hold a value larger than we
* accept.
*/
- if (type2 != TCL_NUMBER_LONG) {
+ if (type2 != TCL_NUMBER_INT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- /* From here (up to overflowExpon) exponent is long (l2). */
+ /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
+ assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);
- 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 = LongPwrSmallExpon(l1, l2);
+ if (w1 == 2) {
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- LONG_RESULT(lResult);
+ if ((Tcl_WideUInt)w2 < (Tcl_WideUInt)CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(((Tcl_WideInt)1) << (int)w2);
}
+ goto overflowExpon;
+ }
+ if (w1 == -2) {
+ int signum = oddExponent ? -1 : 1;
- 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.
- */
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
- LONG_RESULT(lResult);
- }
+ if ((Tcl_WideUInt)w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(signum * (((Tcl_WideInt)1) << (int) w2));
}
-#endif
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
- /* Code below (up to overflowExpon) works with wide-int base */
- w1 = l1;
-#endif
+ goto overflowExpon;
}
-
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
-
- /* From here (up to overflowExpon) base is wide-int (w1). */
-
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
+ if (w2 - 2 < (long)MaxBase64Size
+ && w1 <= MaxBase64[w2 - 2]
+ && w1 >= -MaxBase64[w2 - 2]) {
/*
* Small powers of integers whose result is wide.
*/
- wResult = WidePwrSmallExpon(w1, l2);
+ wResult = WidePwrSmallExpon(w1, (long)w2);
WIDE_RESULT(wResult);
}
@@ -9042,9 +8710,9 @@ ExecuteExtendedBinaryMathOp(
*/
if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -9056,9 +8724,9 @@ ExecuteExtendedBinaryMathOp(
}
if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[-w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[-w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -9069,7 +8737,6 @@ ExecuteExtendedBinaryMathOp(
WIDE_RESULT(wResult);
}
}
-#endif
overflowExpon:
@@ -9081,8 +8748,13 @@ ExecuteExtendedBinaryMathOp(
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- mp_init(&bigResult);
- mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
+ err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
@@ -9135,23 +8807,21 @@ ExecuteExtendedBinaryMathOp(
* Check now for IEEE floating-point error.
*/
- if (TclIsNaN(dResult)) {
+ if (isnan(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);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_ADD:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Check for overflow.
@@ -9165,9 +8835,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2);
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Must check for overflow. The macro tests for overflows
@@ -9187,8 +8855,7 @@ ExecuteExtendedBinaryMathOp(
break;
case INST_MULT:
- if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG)
- || (sizeof(Tcl_WideInt) < 2*sizeof(long))) {
+ if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) {
goto overflowBasic;
}
wResult = w1 * w2;
@@ -9200,10 +8867,10 @@ ExecuteExtendedBinaryMathOp(
}
/*
- * Need a bignum to represent (LLONG_MIN / -1)
+ * Need a bignum to represent (WIDE_MIN / -1)
*/
- if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ if ((w1 == WIDE_MIN) && (w2 == -1)) {
goto overflowBasic;
}
wResult = w1 / w2;
@@ -9234,38 +8901,44 @@ ExecuteExtendedBinaryMathOp(
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
switch (opcode) {
case INST_ADD:
- mp_add(&big1, &big2, &bigResult);
- break;
+ err = mp_add(&big1, &big2, &bigResult);
+ break;
case INST_SUB:
- mp_sub(&big1, &big2, &bigResult);
- break;
+ err = mp_sub(&big1, &big2, &bigResult);
+ break;
case INST_MULT:
- mp_mul(&big1, &big2, &bigResult);
- break;
+ err = 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.
- */
+ if (mp_iszero(&big2)) {
+ mp_clear(&big1);
+ mp_clear(&big2);
+ mp_clear(&bigResult);
+ return DIVIDED_BY_ZERO;
+ }
+ err = mp_init(&bigRemainder);
+ if (err == MP_OKAY) {
+ err = 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);
+ err = mp_sub_d(&bigResult, 1, &bigResult);
+ if (err == MP_OKAY) {
+ err = mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ }
+ mp_clear(&bigRemainder);
+ break;
}
- mp_clear(&bigRemainder);
- break;
}
mp_clear(&big1);
mp_clear(&big2);
@@ -9281,58 +8954,58 @@ ExecuteExtendedUnaryMathOp(
int opcode, /* What operation to perform. */
Tcl_Obj *valuePtr) /* The operand on the stack. */
{
- ClientData ptr = NULL;
+ void *ptr = NULL;
int type;
Tcl_WideInt w;
mp_int big;
Tcl_Obj *objResultPtr;
+ mp_err err = MP_OKAY;
(void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
switch (opcode) {
case INST_BITNOT:
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
+ if (type == TCL_NUMBER_INT) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
-#endif
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
/* ~a = - a - 1 */
- (void)mp_neg(&big, &big);
- mp_sub_d(&big, 1, &big);
+ err = mp_neg(&big, &big);
+ if (err == MP_OKAY) {
+ err = mp_sub_d(&big, 1, &big);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
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 TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w = *((const Tcl_WideInt *) ptr);
- if (w != LLONG_MIN) {
+ if (w != WIDE_MIN) {
WIDE_RESULT(-w);
}
- TclBNInitBignumFromWideInt(&big, w);
+ err = mp_init_i64(&big, w);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
break;
-#endif
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
- (void)mp_neg(&big, &big);
+ err = mp_neg(&big, &big);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&big);
}
Tcl_Panic("unexpected opcode");
return NULL;
}
-#undef LONG_RESULT
#undef WIDE_RESULT
#undef BIG_RESULT
#undef DOUBLE_RESULT
@@ -9361,34 +9034,25 @@ TclCompareTwoNumbers(
Tcl_Obj *value2Ptr)
{
int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare;
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
mp_int big1, big2;
double d1, d2, tmp;
- long l1, l2;
-#ifndef TCL_WIDE_INT_IS_LONG
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);
+ case TCL_NUMBER_INT:
+ w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- longCompare:
- return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
- w1 = (Tcl_WideInt)l1;
- goto wideCompare;
-#endif
+ wideCompare:
+ return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
- d1 = (double) l1;
+ d1 = (double) w1;
/*
* If the double has a fractional part, or if the long can be
@@ -9396,7 +9060,7 @@ TclCompareTwoNumbers(
* doubles.
*/
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt)d1
|| modf(d2, &tmp) != 0.0) {
goto doubleCompare;
}
@@ -9413,52 +9077,13 @@ TclCompareTwoNumbers(
* integer comparison can tell the difference.
*/
- if (d2 < (double)LONG_MIN) {
+ if (d2 < (double)WIDE_MIN) {
return MP_GT;
}
- if (d2 > (double)LONG_MAX) {
+ if (d2 > (double)WIDE_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;
- }
- break;
-
-#ifndef TCL_WIDE_INT_IS_LONG
- 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;
+ w2 = (Tcl_WideInt)d2;
goto wideCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
@@ -9471,7 +9096,6 @@ TclCompareTwoNumbers(
return compare;
}
break;
-#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -9480,44 +9104,27 @@ TclCompareTwoNumbers(
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 TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
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) {
+ || w2 == (Tcl_WideInt)d2 || modf(d1, &tmp) != 0.0) {
goto doubleCompare;
}
- if (d1 < (double)LLONG_MIN) {
+ if (d1 < (double)WIDE_MIN) {
return MP_LT;
}
- if (d1 > (double)LLONG_MAX) {
+ if (d1 > (double)WIDE_MAX) {
return MP_GT;
}
- w1 = (Tcl_WideInt) d1;
+ w1 = (Tcl_WideInt)d1;
goto wideCompare;
-#endif
case TCL_NUMBER_BIG:
- if (TclIsInfinite(d1)) {
+ if (isinf(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
+ if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) {
if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
@@ -9540,21 +9147,18 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
-#endif
- case TCL_NUMBER_LONG:
+ case TCL_NUMBER_INT:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
- if (TclIsInfinite(d2)) {
+ if (isinf(d2)) {
compare = (d2 > 0.0) ? MP_LT : MP_GT;
mp_clear(&big1);
return compare;
}
- if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
+ if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) {
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
@@ -9609,10 +9213,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n",
+ codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
-
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
@@ -9627,13 +9230,13 @@ PrintByteCodeInfo(
0.0);
#ifdef TCL_COMPILE_STATS
- fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
+ fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n",
(unsigned long) codePtr->structureSize,
- (unsigned long) (TclOffset(ByteCode, localCachePtr)),
+ offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
- (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
- (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
- (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numLitObjects * sizeof(Tcl_Obj *),
+ codePtr->numExceptRanges*sizeof(ExceptionRange),
+ codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
@@ -9671,44 +9274,44 @@ ValidatePcAndStackTop(
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
- int stackTop, /* Current stack top. Must be between
+ size_t stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
- int stackUpperBound = codePtr->maxStackDepth;
+ size_t stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
- size_t relativePc = (size_t) (pc - codePtr->codeStart);
- size_t codeStart = (size_t) codePtr->codeStart;
+ size_t relativePc = (size_t)(pc - codePtr->codeStart);
+ size_t codeStart = (size_t)codePtr->codeStart;
size_t codeEnd = (size_t)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
- if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) {
+ if ((PTR2UINT(pc) < codeStart) || (PTR2UINT(pc) > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if ((unsigned) opCode > LAST_INST_OPCODE) {
- fprintf(stderr, "\nBad opcode %d at pc %lu in TclNRExecuteByteCode\n",
- (unsigned) opCode, (unsigned long)relativePc);
+ fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
+ (unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
- ((stackTop < 0) || (stackTop > stackUpperBound))) {
+ (stackTop > stackUpperBound)) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %lu in TclNRExecuteByteCode (min 0, max %i)",
- stackTop, (unsigned long)relativePc, stackUpperBound);
+ fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)",
+ stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
- fprintf(stderr,"%s\n", Tcl_GetString(message));
+ fprintf(stderr,"%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
@@ -9745,7 +9348,7 @@ IllegalExprOperandType(
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
- ClientData ptr;
+ void *ptr;
int type;
const unsigned char opcode = *pc;
const char *description, *op = "unknown";
@@ -9758,7 +9361,7 @@ IllegalExprOperandType(
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
+ const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
@@ -9777,7 +9380,8 @@ IllegalExprOperandType(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't use %s as operand of \"%s\"", description, op));
+ "can't use %s \"%s\" as operand of \"%s\"", description,
+ TclGetString(opndPtr), op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
}
@@ -9854,7 +9458,8 @@ TclGetSrcInfoForPc(
ExtCmdLoc *eclPtr;
ECL *locPtr = NULL;
- int srcOffset, i;
+ int srcOffset;
+ int i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
@@ -9864,7 +9469,7 @@ TclGetSrcInfoForPc(
}
srcOffset = cfPtr->cmd - codePtr->source;
- eclPtr = Tcl_GetHashValue(hePtr);
+ eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
@@ -10089,7 +9694,7 @@ GetExceptRangeForPc(
if (searchMode == TCL_BREAK) {
return rangePtr;
}
- if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){
+ if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){
return rangePtr;
}
}
@@ -10152,11 +9757,11 @@ TclExprFloatError(
{
const char *s;
- if ((errno == EDOM) || TclIsNaN(value)) {
+ if ((errno == EDOM) || isnan(value)) {
s = "domain error: argument not in valid range";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
- } else if ((errno == ERANGE) || TclIsInfinite(value)) {
+ } else if ((errno == ERANGE) || isinf(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
@@ -10171,7 +9776,7 @@ TclExprFloatError(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
@@ -10229,7 +9834,7 @@ TclLog2(
static int
EvalStatsCmd(
- ClientData unused, /* Unused. */
+ TCL_UNUSED(void *), /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The argument strings. */
@@ -10242,10 +9847,10 @@ EvalStatsCmd(
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
- long numCurrentByteCodes, numByteCodeLits;
- long refCountSum, literalMgmtBytes, sum;
- int numSharedMultX, numSharedOnce;
- int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
+ size_t numCurrentByteCodes, numByteCodeLits;
+ size_t refCountSum, literalMgmtBytes, sum;
+ size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i;
+ int decadeHigh, length;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
@@ -10272,7 +9877,7 @@ EvalStatsCmd(
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
- * (TclOffset(ByteCode, localCachePtr));
+ * offsetof(ByteCode, localCachePtr);
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
@@ -10287,12 +9892,12 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
- "Compilation and execution statistics for interpreter %#lx\n",
- (unsigned long)(size_t)iPtr);
+ "Compilation and execution statistics for interpreter %p\n",
+ iPtr);
- Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
@@ -10304,7 +9909,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
@@ -10314,18 +9919,18 @@ EvalStatsCmd(
statsPtr->totalByteCodeBytes);
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),
- (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
- (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
- (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
+ Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
+ statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n",
numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
@@ -10335,11 +9940,11 @@ EvalStatsCmd(
statsPtr->currentByteCodeBytes);
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),
- (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
- (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
- (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
+ Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ iPtr->literalTable.numEntries * sizeof(LiteralEntry),
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
@@ -10356,17 +9961,17 @@ EvalStatsCmd(
numSharedMultX = 0;
Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
- Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
- Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
- Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
- Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
/*
@@ -10384,10 +9989,10 @@ EvalStatsCmd(
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
- if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
+ if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
- (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ (void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
@@ -10403,20 +10008,20 @@ EvalStatsCmd(
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
- Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
tclObjsAlloced);
- Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
(tclObjsAlloced - tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
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\t\t%ld (%0.1f%% of current literals)\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
- Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
@@ -10441,7 +10046,7 @@ EvalStatsCmd(
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\t\t%ld (%0.1f%% of bytes with sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,
Percent(literalMgmtBytes, currentLiteralBytes));
Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
@@ -10491,7 +10096,8 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
- for (i = 31; i >= 0; i--) {
+ i = 32;
+ while (i-- > 0) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10523,7 +10129,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->srcCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10546,7 +10152,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10569,7 +10175,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10589,7 +10195,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
- Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
+ Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ",
tclInstructionTable[i].name, statsPtr->instructionCount[i]);
if (statsPtr->instructionCount[i]) {
Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
@@ -10601,7 +10207,7 @@ EvalStatsCmd(
#ifdef TCL_MEM_DEBUG
Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
- TclDumpMemoryInfo((ClientData) objPtr, 1);
+ TclDumpMemoryInfo(objPtr, 1);
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
@@ -10609,7 +10215,7 @@ EvalStatsCmd(
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
- char *str = Tcl_GetStringFromObj(objv[1], &length);
+ char *str = TclGetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index d58d02d..2d24207 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -4,7 +4,7 @@
* This file implements the generic portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -47,7 +47,7 @@ static int FileForceOption(Tcl_Interp *interp,
int
TclFileRenameCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
@@ -76,7 +76,7 @@ TclFileRenameCmd(
int
TclFileCopyCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
@@ -214,7 +214,7 @@ FileCopyRename(
int
TclFileMakeDirsCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
@@ -338,7 +338,7 @@ TclFileMakeDirsCmd(
int
TclFileDeleteCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
@@ -946,7 +946,7 @@ FileBasename(
int
TclFileAttrsCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
@@ -1006,7 +1006,7 @@ TclFileAttrsCmd(
* Use objStrings as a list object.
*/
- if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
+ if (TclListObjLengthM(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStringsAllocated = (const char **)
@@ -1085,12 +1085,9 @@ TclFileAttrsCmd(
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[0]);
- }
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
@@ -1113,12 +1110,9 @@ TclFileAttrsCmd(
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[i]);
- }
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
@@ -1168,7 +1162,7 @@ TclFileAttrsCmd(
int
TclFileLinkCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1319,7 +1313,7 @@ TclFileLinkCmd(
int
TclFileReadLinkCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1351,7 +1345,7 @@ TclFileReadLinkCmd(
/*
*---------------------------------------------------------------------------
*
- * TclFileTemporaryCmd
+ * TclFileTemporaryCmd --
*
* This function implements the "tempfile" subcommand of the "file"
* command.
@@ -1370,7 +1364,7 @@ TclFileReadLinkCmd(
int
TclFileTemporaryCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1511,6 +1505,227 @@ TclFileTemporaryCmd(
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileTempDirCmd --
+ *
+ * This function implements the "tempdir" subcommand of the "file"
+ * command.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Creates a temporary directory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFileTempDirCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *dirNameObj; /* Object that will contain the directory
+ * name. */
+ Tcl_Obj *baseDirObj = NULL, *nameBaseObj = 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 > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?template?");
+ return TCL_ERROR;
+ }
+
+ if (objc > 1) {
+ int length;
+ Tcl_Obj *templateObj = objv[1];
+ const char *string = TclGetStringFromObj(templateObj, &length);
+ const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
+
+ /*
+ * Treat an empty string as if it wasn't there.
+ */
+
+ if (length == 0) {
+ goto makeTemporary;
+ }
+
+ /*
+ * The template only gives a directory if there is a directory
+ * separator in it, and only gives a base name if there's at least one
+ * character after the last directory separator.
+ */
+
+ if (strchr(string, '/') == NULL
+ && (!onWindows || strchr(string, '\\') == NULL)) {
+ /*
+ * No directory separator, so just assume we have a file name.
+ * This is a bit wrong on Windows where we could have problems
+ * with disk name prefixes... but those are much less common in
+ * naked form so we just pass through and let the OS figure it out
+ * instead.
+ */
+
+ nameBaseObj = templateObj;
+ Tcl_IncrRefCount(nameBaseObj);
+ } else if (string[length-1] != '/'
+ && (!onWindows || string[length-1] != '\\')) {
+ /*
+ * If the template has a non-terminal directory separator, split
+ * into dirname and tail.
+ */
+
+ baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
+ nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL);
+ } else {
+ /*
+ * Otherwise, there must be a terminal directory separator, so
+ * just the directory is given.
+ */
+
+ baseDirObj = templateObj;
+ Tcl_IncrRefCount(baseDirObj);
+ }
+
+ /*
+ * Only allow creation of temporary directories in the native
+ * filesystem since they are frequently used for integration with
+ * external tools or system libraries.
+ */
+
+ if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj)
+ != &tclNativeFilesystem) {
+ TclDecrRefCount(baseDirObj);
+ baseDirObj = NULL;
+ }
+ }
+
+ /*
+ * Convert empty parts of the template into unspecified parts.
+ */
+
+ if (baseDirObj && !TclGetString(baseDirObj)[0]) {
+ TclDecrRefCount(baseDirObj);
+ baseDirObj = NULL;
+ }
+ if (nameBaseObj && !TclGetString(nameBaseObj)[0]) {
+ TclDecrRefCount(nameBaseObj);
+ nameBaseObj = NULL;
+ }
+
+ /*
+ * Create and open the temporary file.
+ */
+
+ makeTemporary:
+ dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj);
+
+ /*
+ * If we created pieces of template, get rid of them now.
+ */
+
+ if (baseDirObj) {
+ TclDecrRefCount(baseDirObj);
+ }
+ if (nameBaseObj) {
+ TclDecrRefCount(nameBaseObj);
+ }
+
+ /*
+ * Deal with results.
+ */
+
+ if (dirNameObj == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create temporary directory: %s",
+ Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, dirNameObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFileHomeCmd --
+ *
+ * This function is invoked to process the "file home" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFileHomeCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *homeDirObj;
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?user?");
+ return TCL_ERROR;
+ }
+ homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1]));
+ if (homeDirObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, homeDirObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFileTildeExpandCmd --
+ *
+ * This function is invoked to process the "file tildeexpand" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFileTildeExpandCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *expandedPathObj;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "path");
+ return TCL_ERROR;
+ }
+ expandedPathObj = TclResolveTildePath(interp, objv[1]);
+ if (expandedPathObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, expandedPathObj);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index dcd3d0e..3ca1ab5 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -4,8 +4,8 @@
* This file contains routines for converting file names betwen native
* and network form.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
+ * Copyright © 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -37,6 +37,17 @@ 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);
+static int TclGlob(Tcl_Interp *interp, char *pattern,
+ Tcl_Obj *pathPrefix, int globFlags,
+ Tcl_GlobTypeData *types);
+
+/* Flag values used by TclGlob() */
+
+#ifdef TCL_NO_DEPRECATED
+# define TCL_GLOBMODE_NO_COMPLAIN 1
+# define TCL_GLOBMODE_DIR 4
+# define TCL_GLOBMODE_TAILS 8
+#endif
/*
* When there is no support for getting the block size of a file in a stat()
@@ -387,7 +398,7 @@ TclpGetNativePathType(
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
- const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = TclGetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -413,7 +424,6 @@ TclpGetNativePathType(
if (path[0] == '/') {
++path;
-#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
@@ -423,7 +433,6 @@ TclpGetNativePathType(
++path;
}
}
-#endif
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the "//" code was used.
@@ -445,7 +454,7 @@ TclpGetNativePathType(
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
- *driveNameRef = TclDStringToObj(&ds);
+ *driveNameRef = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
@@ -506,7 +515,7 @@ TclpNativeSplitPath(
*/
if (lenPtr != NULL) {
- TclListObjLength(NULL, resultPtr, lenPtr);
+ TclListObjLengthM(NULL, resultPtr, lenPtr);
}
return resultPtr;
}
@@ -536,6 +545,7 @@ TclpNativeSplitPath(
*----------------------------------------------------------------------
*/
+#undef Tcl_SplitPath
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
@@ -567,7 +577,7 @@ Tcl_SplitPath(
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- Tcl_GetStringFromObj(eltPtr, &len);
+ TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
@@ -587,7 +597,7 @@ Tcl_SplitPath(
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- str = Tcl_GetStringFromObj(eltPtr, &len);
+ str = TclGetStringFromObj(eltPtr, &len);
memcpy(p, str, len + 1);
p += len+1;
}
@@ -644,7 +654,6 @@ SplitUnixPath(
if (*path == '/') {
Tcl_Obj *rootElt;
++path;
-#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
@@ -654,7 +663,6 @@ SplitUnixPath(
++path;
}
}
-#endif
rootElt = Tcl_NewStringObj(origPath, path - origPath);
Tcl_ListObjAppendElement(NULL, result, rootElt);
while (*path == '/') {
@@ -726,7 +734,7 @@ SplitWinPath(
*/
if (p != path) {
- Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
+ Tcl_ListObjAppendElement(NULL, result, Tcl_DStringToObj(&buf));
}
Tcl_DStringFree(&buf);
@@ -838,7 +846,7 @@ TclpNativeJoinPath(
const char *p;
const char *start;
- start = Tcl_GetStringFromObj(prefix, &length);
+ start = TclGetStringFromObj(prefix, &length);
/*
* Remove the ./ from tilde prefixed elements, and drive-letter prefixed
@@ -866,7 +874,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -902,7 +910,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -985,7 +993,7 @@ Tcl_JoinPath(
* Store the result.
*/
- resultStr = Tcl_GetStringFromObj(resultObj, &len);
+ resultStr = TclGetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
@@ -1201,7 +1209,7 @@ DoTildeSubst(
int
Tcl_GlobObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1222,7 +1230,6 @@ Tcl_GlobObjCmd(
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
- (void)dummy;
globFlags = 0;
join = 0;
@@ -1231,7 +1238,7 @@ Tcl_GlobObjCmd(
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
- string = Tcl_GetStringFromObj(objv[i], &length);
+ string = TclGetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal an
@@ -1311,7 +1318,7 @@ Tcl_GlobObjCmd(
return TCL_ERROR;
}
typePtr = objv[i+1];
- if (TclListObjLength(interp, typePtr, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
@@ -1345,7 +1352,7 @@ Tcl_GlobObjCmd(
if (dir == PATH_GENERAL) {
int pathlength;
const char *last;
- const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
+ const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
@@ -1433,7 +1440,7 @@ Tcl_GlobObjCmd(
* platform.
*/
- TclListObjLength(interp, typePtr, &length);
+ TclListObjLengthM(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
@@ -1448,7 +1455,7 @@ Tcl_GlobObjCmd(
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
- str = Tcl_GetStringFromObj(look, &len);
+ str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
@@ -1503,7 +1510,7 @@ Tcl_GlobObjCmd(
} else {
Tcl_Obj *item;
- if ((TclListObjLength(NULL, look, &len) == TCL_OK)
+ if ((TclListObjLengthM(NULL, look, &len) == TCL_OK)
&& (len == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", Tcl_GetString(item))) {
@@ -1610,7 +1617,7 @@ Tcl_GlobObjCmd(
}
if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
- if (TclListObjLength(interp, Tcl_GetObjResult(interp),
+ if (TclListObjLengthM(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/*
* This should never happen. Maybe we should be more dramatic.
@@ -1692,7 +1699,7 @@ Tcl_GlobObjCmd(
*----------------------------------------------------------------------
*/
-int
+static int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
* appending list of matching file names. */
@@ -1760,7 +1767,7 @@ TclGlob(
if (head != Tcl_DStringValue(&buffer)) {
Tcl_DStringAppend(&buffer, head, -1);
}
- pathPrefix = TclDStringToObj(&buffer);
+ pathPrefix = Tcl_DStringToObj(&buffer);
Tcl_IncrRefCount(pathPrefix);
globFlags |= TCL_GLOBMODE_DIR;
if (c != '\0') {
@@ -1867,11 +1874,7 @@ TclGlob(
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (pathPrefix == NULL && tail[0] == '/'
-#if defined(__CYGWIN__) || defined(__QNX__)
- && tail[1] != '/'
-#endif
- ) {
+ if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') {
pathPrefix = Tcl_NewStringObj(tail, 1);
tail++;
Tcl_IncrRefCount(pathPrefix);
@@ -1982,7 +1985,7 @@ TclGlob(
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
- pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
+ pre = TclGetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
@@ -1997,10 +2000,10 @@ TclGlob(
}
}
- TclListObjGetElements(NULL, filenamesObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
- const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
+ const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
@@ -2326,13 +2329,13 @@ DoGlob(
int subdirc, i, repair = -1;
Tcl_Obj **subdirv;
- result = TclListObjGetElements(interp, subdirsPtr,
+ result = TclListObjGetElementsM(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
if (pathPtr == NULL && Tcl_GetString(subdirv[i])[0] == '~') {
- TclListObjLength(NULL, matchesObj, &repair);
+ TclListObjLengthM(NULL, matchesObj, &repair);
copy = subdirv[i];
subdirv[i] = Tcl_NewStringObj("./", 2);
Tcl_AppendObjToObj(subdirv[i], copy);
@@ -2345,14 +2348,14 @@ DoGlob(
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
- TclListObjLength(NULL, matchesObj, &end);
+ TclListObjLengthM(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
int numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
- bytes = Tcl_GetStringFromObj(fixme, &numBytes);
+ bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
@@ -2390,7 +2393,7 @@ DoGlob(
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
- (void) Tcl_GetStringFromObj(pathPtr, &length);
+ (void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
@@ -2424,7 +2427,7 @@ DoGlob(
*/
if (pathPtr == NULL) {
- joinedPtr = TclDStringToObj(&append);
+ joinedPtr = Tcl_DStringToObj(&append);
} else if (flags) {
joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
@@ -2436,7 +2439,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
@@ -2473,7 +2476,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
@@ -2538,21 +2541,21 @@ unsigned
Tcl_GetFSDeviceFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_dev;
+ return statPtr->st_dev;
}
unsigned
Tcl_GetFSInodeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_ino;
+ return statPtr->st_ino;
}
unsigned
Tcl_GetModeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_mode;
+ return statPtr->st_mode;
}
int
@@ -2583,61 +2586,66 @@ Tcl_GetDeviceTypeFromStat(
return (int) statPtr->st_rdev;
}
-Tcl_WideInt
+long long
Tcl_GetAccessTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_atime;
+ return (long long) statPtr->st_atime;
}
-Tcl_WideInt
+long long
Tcl_GetModificationTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_mtime;
+ return (long long) statPtr->st_mtime;
}
-Tcl_WideInt
+long long
Tcl_GetChangeTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_ctime;
+ return (long long) statPtr->st_ctime;
}
-Tcl_WideUInt
+unsigned long long
Tcl_GetSizeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideUInt) statPtr->st_size;
+ return (unsigned long long) statPtr->st_size;
}
-Tcl_WideUInt
+unsigned long long
Tcl_GetBlocksFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- return (Tcl_WideUInt) statPtr->st_blocks;
+ return (unsigned long long) statPtr->st_blocks;
#else
unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
- return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
+ return ((unsigned long long) statPtr->st_size + blksize - 1) / blksize;
#endif
}
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
-#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- return (unsigned) statPtr->st_blksize;
+ return statPtr->st_blksize;
+}
#else
+unsigned
+Tcl_GetBlockSizeFromStat(
+ TCL_UNUSED(const Tcl_StatBuf *))
+{
/*
* Not a great guess, but will do...
*/
return GUESSED_BLOCK_SIZE;
-#endif
}
+#endif
/*
* Local Variables:
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index e5dcffb..503b204 100644
--- a/generic/tclFileSystem.h
+++ b/generic/tclFileSystem.h
@@ -30,7 +30,7 @@ MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp,
MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr,
- const Tcl_Filesystem *fsPtr, ClientData clientData);
+ const Tcl_Filesystem *fsPtr, void *clientData);
MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
MODULE_SCOPE size_t TclFSEpoch(void);
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 2f06cff..bb3f8f1 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -5,8 +5,8 @@
* integers or floating-point numbers or booleans, doing syntax checking
* along the way.
*
- * Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1990-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -53,7 +53,7 @@ Tcl_GetInt(
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- TclFreeIntRep(&obj);
+ TclFreeInternalRep(&obj);
return code;
}
@@ -97,7 +97,7 @@ Tcl_GetDouble(
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- TclFreeIntRep(&obj);
+ TclFreeInternalRep(&obj);
return code;
}
@@ -110,7 +110,7 @@ Tcl_GetDouble(
* string.
*
* Results:
- * The return value is normally TCL_OK; in this case *intPtr will be set
+ * The return value is normally TCL_OK; in this case *charPtr will be set
* to the 0/1 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.
@@ -121,17 +121,23 @@ Tcl_GetDouble(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetBool
+#undef Tcl_GetBoolFromObj
int
-Tcl_GetBoolean(
+Tcl_GetBool(
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. */
- int *intPtr) /* Place to store converted result, which will
+ int flags,
+ char *charPtr) /* Place to store converted result, which will
* be 0 or 1. */
{
Tcl_Obj obj;
int code;
+ if ((src == NULL) || (*src == '\0')) {
+ return Tcl_GetBoolFromObj(interp, NULL, flags, charPtr);
+ }
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
@@ -142,10 +148,22 @@ Tcl_GetBoolean(
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
- *intPtr = obj.internalRep.longValue;
+ Tcl_GetBoolFromObj(NULL, &obj, flags, charPtr);
}
return code;
}
+
+#undef Tcl_GetBoolean
+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. */
+ int *intPtr) /* Place to store converted result, which will
+ * be 0 or 1. */
+{
+ return Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr);
+}
/*
* Local Variables:
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index 412f03f..e85184b 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -959,7 +959,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
@@ -969,7 +969,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 709831d..37e45e7 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -4,8 +4,8 @@
* Implementation of in-memory hash tables for Tcl and Tcl-based
* applications.
*
- * Copyright (c) 1991-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
+ * Copyright © 1991-1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -43,20 +43,7 @@
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. Not actually declared because
- * this is a critical path that is implemented in the core hash table access
- * function.
- */
-
-#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);
-#endif
+static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the string hash key methods.
@@ -65,7 +52,7 @@ 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);
+static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Function prototypes for static functions in this file:
@@ -232,7 +219,7 @@ Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key) /* Key to use to find matching entry. */
{
- return (*((tablePtr)->findProc))(tablePtr, key);
+ return (*((tablePtr)->findProc))(tablePtr, (const char *)key);
}
static Tcl_HashEntry *
@@ -273,7 +260,7 @@ Tcl_CreateHashEntry(
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
- return (*((tablePtr)->createProc))(tablePtr, key, newPtr);
+ return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
}
static Tcl_HashEntry *
@@ -286,8 +273,7 @@ CreateHashEntry(
{
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
- unsigned int hash;
- int index;
+ TCL_HASH_TYPE hash, index;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
@@ -321,11 +307,9 @@ CreateHashEntry(
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
|| compareKeysProc((void *) key, hPtr)
@@ -339,11 +323,9 @@ CreateHashEntry(
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
if (key == hPtr->key.oneWordValue) {
if (newPtr) {
*newPtr = 0;
@@ -365,21 +347,15 @@ CreateHashEntry(
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
- hPtr = ckalloc(sizeof(Tcl_HashEntry));
+ hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
- hPtr->clientData = 0;
+ Tcl_SetHashValue(hPtr, NULL);
}
hPtr->tablePtr = tablePtr;
-#if TCL_HASH_KEY_STORE_HASH
hPtr->hash = UINT2PTR(hash);
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
tablePtr->numEntries++;
/*
@@ -419,9 +395,7 @@ Tcl_DeleteHashEntry(
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
-#if TCL_HASH_KEY_STORE_HASH
- int index;
-#endif
+ TCL_HASH_TYPE index;
tablePtr = entryPtr->tablePtr;
@@ -436,18 +410,14 @@ Tcl_DeleteHashEntry(
typePtr = &tclArrayHashKeyType;
}
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash));
+ index = RANDOM_INDEX(tablePtr, PTR2UINT(entryPtr->hash));
} else {
index = PTR2UINT(entryPtr->hash) & tablePtr->mask;
}
bucketPtr = &tablePtr->buckets[index];
-#else
- bucketPtr = entryPtr->bucketPtr;
-#endif
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
@@ -643,7 +613,8 @@ Tcl_HashStats(
Tcl_HashTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
- int count[NUM_COUNTERS], overflow, i, j;
+ int i;
+ TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j;
double average, tmp;
Tcl_HashEntry *hPtr;
char *result, *p;
@@ -677,16 +648,16 @@ Tcl_HashStats(
* Print out the histogram and a few other pieces of information.
*/
- result = ckalloc((NUM_COUNTERS * 60) + 300);
- sprintf(result, "%d entries in table, %d buckets\n",
+ result = (char *)ckalloc((NUM_COUNTERS * 60) + 300);
+ sprintf(result, "%u entries in table, %u buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
- sprintf(p, "number of buckets with %d entries: %d\n",
+ sprintf(p, "number of buckets with %u entries: %u\n",
i, count[i]);
p += strlen(p);
}
- sprintf(p, "number of buckets with %d or more entries: %d\n",
+ sprintf(p, "number of buckets with %u or more entries: %u\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
@@ -712,27 +683,19 @@ 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;
- int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
- int count;
- unsigned int size;
+ TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int);
+ TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count;
- count = tablePtr->keyType;
-
- size = TclOffset(Tcl_HashEntry, key) + count*sizeof(int);
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
- hPtr = ckalloc(size);
+ hPtr = (Tcl_HashEntry *)ckalloc(size);
- for (iPtr1 = array, iPtr2 = hPtr->key.words;
- count > 0; count--, iPtr1++, iPtr2++) {
- *iPtr2 = *iPtr1;
- }
- hPtr->clientData = 0;
+ memcpy(hPtr->key.string, keyPtr, count);
+ Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
@@ -756,23 +719,12 @@ AllocArrayEntry(
static int
CompareArrayKeys(
- void *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- const int *iPtr1 = (const int *) keyPtr;
- const int *iPtr2 = (const int *) hPtr->key.words;
- Tcl_HashTable *tablePtr = hPtr->tablePtr;
- int count;
+ size_t count = hPtr->tablePtr->keyType * sizeof(int);
- for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
- if (count == 0) {
- return 1;
- }
- if (*iPtr1 != *iPtr2) {
- break;
- }
- }
- return 0;
+ return !memcmp(keyPtr, hPtr->key.string, count);
}
/*
@@ -793,13 +745,13 @@ CompareArrayKeys(
*----------------------------------------------------------------------
*/
-static unsigned int
+static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key from which to compute hash value. */
+ void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
- unsigned int result;
+ TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
@@ -827,21 +779,21 @@ HashArrayKey(
static Tcl_HashEntry *
AllocStringEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key to store in the hash table entry. */
+ TCL_UNUSED(Tcl_HashTable *),
+ void *keyPtr) /* Key to store in the hash table entry. */
{
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
- unsigned int size, allocsize;
+ size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
- hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize);
- memset(hPtr, 0, TclOffset(Tcl_HashEntry, key) + allocsize);
+ hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize);
+ memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
- hPtr->clientData = 0;
+ Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
@@ -864,13 +816,10 @@ AllocStringEntry(
static int
CompareStringKeys(
- void *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- const char *p1 = (const char *) keyPtr;
- const char *p2 = (const char *) hPtr->key.string;
-
- return !strcmp(p1, p2);
+ return !strcmp((char *)keyPtr, hPtr->key.string);
}
/*
@@ -890,13 +839,13 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
-static unsigned
+static TCL_HASH_TYPE
HashStringKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key from which to compute hash value. */
+ TCL_UNUSED(Tcl_HashTable *),
+ void *keyPtr) /* Key from which to compute hash value. */
{
- const char *string = keyPtr;
- unsigned int result;
+ const char *string = (const char *)keyPtr;
+ TCL_HASH_TYPE result;
char c;
/*
@@ -944,7 +893,7 @@ HashStringKey(
*
* BogusFind --
*
- * This function is invoked when an Tcl_FindHashEntry is called on a
+ * This function is invoked when Tcl_FindHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -956,11 +905,10 @@ HashStringKey(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static Tcl_HashEntry *
BogusFind(
- Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key) /* Key to use to find matching entry. */
+ TCL_UNUSED(Tcl_HashTable *),
+ TCL_UNUSED(const char *))
{
Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry");
return NULL;
@@ -971,7 +919,7 @@ BogusFind(
*
* BogusCreate --
*
- * This function is invoked when an Tcl_CreateHashEntry is called on a
+ * This function is invoked when Tcl_CreateHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -983,14 +931,11 @@ BogusFind(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static Tcl_HashEntry *
BogusCreate(
- Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key, /* Key to use to find or create matching
- * entry. */
- int *newPtr) /* Store info here telling whether a new entry
- * was created. */
+ TCL_UNUSED(Tcl_HashTable *),
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(int *))
{
Tcl_Panic("called %s on deleted table", "Tcl_CreateHashEntry");
return NULL;
@@ -1018,14 +963,14 @@ static void
RebuildTable(
Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
- int count, index, oldSize = tablePtr->numBuckets;
+ TCL_HASH_TYPE count, index, oldSize = tablePtr->numBuckets;
Tcl_HashEntry **oldBuckets = tablePtr->buckets;
Tcl_HashEntry **oldChainPtr, **newChainPtr;
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
/* Avoid outgrowing capability of the memory allocators */
- if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
+ if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) {
tablePtr->rebuildSize = INT_MAX;
return;
}
@@ -1048,18 +993,20 @@ RebuildTable(
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
- tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
- (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
+ tablePtr->buckets = (Tcl_HashEntry **)TclpSysAlloc(
+ tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0);
} else {
tablePtr->buckets =
- ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
+ (Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
}
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
- tablePtr->downShift -= 2;
+ if (tablePtr->downShift > 1) {
+ tablePtr->downShift -= 2;
+ }
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
@@ -1069,35 +1016,14 @@ RebuildTable(
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash));
+ index = RANDOM_INDEX(tablePtr, PTR2UINT(hPtr->hash));
} else {
index = PTR2UINT(hPtr->hash) & tablePtr->mask;
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- 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);
- } else {
- index = hash & tablePtr->mask;
- }
- } else {
- index = RANDOM_INDEX(tablePtr, key);
- }
-
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
}
}
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index 24f6d65..02e15a0 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -6,8 +6,8 @@
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*
- * Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1990-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -62,15 +62,14 @@ Tcl_RecordAndEval(
* instead of Tcl_Eval. */
{
Tcl_Obj *cmdPtr;
- int length = strlen(cmd);
int result;
- if (length > 0) {
+ if (cmd[0]) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
- cmdPtr = Tcl_NewStringObj(cmd, length);
+ cmdPtr = Tcl_NewStringObj(cmd, -1);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
@@ -131,14 +130,14 @@ Tcl_RecordAndEvalObj(
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
- Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
+ (HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
- histObjsPtr = ckalloc(sizeof(HistoryObjs));
+ histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
@@ -212,9 +211,9 @@ Tcl_RecordAndEvalObj(
static void
DeleteHistoryObjs(
ClientData clientData,
- Tcl_Interp *interp)
+ TCL_UNUSED(Tcl_Interp *))
{
- HistoryObjs *histObjsPtr = clientData;
+ HistoryObjs *histObjsPtr = (HistoryObjs *)clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 85ff39b..fed469c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4,8 +4,8 @@
* This file provides the generic portions (those that are the same on
* all platforms and for all channel types) of Tcl's IO facilities.
*
- * Copyright (c) 1998-2000 Ajuba Solutions
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
* Contributions from Don Porter, NIST, 2014. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution of
@@ -28,7 +28,7 @@ typedef struct ChannelHandler {
int mask; /* Mask of desired events. */
Tcl_ChannelProc *proc; /* Procedure to call in the type of
* Tcl_CreateChannelHandler. */
- ClientData clientData; /* Argument to pass to procedure. */
+ void *clientData; /* Argument to pass to procedure. */
struct ChannelHandler *nextPtr;
/* Next one in list of registered handlers. */
} ChannelHandler;
@@ -103,7 +103,7 @@ typedef struct CopyState {
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
int bufSize; /* Size of appended buffer. */
- char buffer[1]; /* Copy buffer, this must be the last
+ char buffer[TCLFLEXARRAY]; /* Copy buffer, this must be the last
* field. */
} CopyState;
@@ -116,7 +116,7 @@ typedef struct CopyState {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
NextChannelHandler *nestedHandlerPtr;
/* This variable holds the list of nested
* Tcl_NotifyChannel invocations. */
@@ -125,12 +125,12 @@ typedef struct ThreadSpecificData {
* ChannelState exists per set of stacked
* channels. */
Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */
- int stdinInitialized;
Tcl_Channel stdoutChannel; /* Static variable for the stdout channel. */
- int stdoutInitialized;
Tcl_Channel stderrChannel; /* Static variable for the stderr channel. */
- int stderrInitialized;
Tcl_Encoding binaryEncoding;
+ int stdinInitialized;
+ int stdoutInitialized;
+ int stderrInitialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -142,7 +142,7 @@ static Tcl_ThreadDataKey dataKey;
typedef struct CloseCallback {
Tcl_CloseProc *proc; /* The procedure to call. */
- ClientData clientData; /* Arbitrary one-word data to pass
+ void *clientData; /* Arbitrary one-word data to pass
* to the callback. */
struct CloseCallback *nextPtr; /* For chaining close callbacks. */
} CloseCallback;
@@ -156,7 +156,7 @@ static void PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int IsShared(ChannelBuffer *bufPtr);
static void ChannelFree(Channel *chanPtr);
-static void ChannelTimerProc(ClientData clientData);
+static void ChannelTimerProc(void *clientData);
static int ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int CheckChannelErrors(ChannelState *statePtr,
int direction);
@@ -178,12 +178,12 @@ static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj);
static void MBError(CopyState *csPtr, int mask, int errorCode);
static int MBRead(CopyState *csPtr);
static int MBWrite(CopyState *csPtr);
-static void MBEvent(ClientData clientData, int mask);
+static void MBEvent(void *clientData, int mask);
-static void CopyEventProc(ClientData clientData, int mask);
+static void CopyEventProc(void *clientData, int mask);
static void CreateScriptRecord(Tcl_Interp *interp,
Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
-static void DeleteChannelTable(ClientData clientData,
+static void DeleteChannelTable(void *clientData,
Tcl_Interp *interp);
static void DeleteScriptRecord(Tcl_Interp *interp,
Channel *chanPtr, int mask);
@@ -201,7 +201,7 @@ static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
int calledFromAsyncFlush);
static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static Tcl_Encoding GetBinaryEncoding(void);
-static void FreeBinaryEncoding(ClientData clientData);
+static Tcl_ExitProc FreeBinaryEncoding;
static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp);
static int GetInput(Channel *chanPtr);
static void PeekAhead(Channel *chanPtr, char **dstEndPtr,
@@ -319,9 +319,9 @@ static int WillRead(Channel *chanPtr);
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
- int epoch; /* The epoch of the channel when the lookup
+ size_t epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
- int refCount; /* Share this struct among many Tcl_Obj. */
+ size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -335,6 +335,22 @@ static const Tcl_ObjType chanObjType = {
NULL /* setFromAnyProc */
};
+#define ChanSetInternalRep(objPtr, resPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (resPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (resPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \
+ } while (0)
+
+#define ChanGetInternalRep(objPtr, resPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &chanObjType); \
+ (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -358,11 +374,12 @@ ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
+#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) {
return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp);
- } else {
- return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
+#endif
+ return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
/*
@@ -376,13 +393,13 @@ ChanClose(
* Results:
* The return value of the driver inputProc,
* - number of bytes stored at dst, ot
- * - -1 on error, with a Posix error code available to the caller by
+ * - TCL_INDEX_NONE on error, with a Posix error code available to the caller by
* calling Tcl_GetErrno().
*
* Side effects:
- * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set
- * as appropriate. On EOF, the inputEncodingFlags are set to perform
- * ending operations on decoding.
+ * The CHANNEL_ENCODING_ERROR, CHANNEL_BLOCKED and CHANNEL_EOF flags
+ * of the channel state are set as appropriate. On EOF, the
+ * inputEncodingFlags are set to perform ending operations on decoding.
*
* TODO - Is this really the right place for that?
*
@@ -414,7 +431,7 @@ ChanRead(
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (WillRead(chanPtr) < 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
@@ -429,7 +446,16 @@ ChanRead(
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
- if (bytesRead > 0) {
+ if (bytesRead < 0) {
+ if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
+ SetFlag(chanPtr->state, CHANNEL_BLOCKED);
+ result = EAGAIN;
+ }
+ Tcl_SetErrno(result);
+ } else if (bytesRead == 0) {
+ SetFlag(chanPtr->state, CHANNEL_EOF);
+ chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
+ } else {
/*
* If we get a short read, signal up that we may be BLOCKED. We should
* avoid calling the driver because on some platforms we will block in
@@ -440,15 +466,6 @@ ChanRead(
if (bytesRead < dstSize) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
}
- } else if (bytesRead == 0) {
- SetFlag(chanPtr->state, CHANNEL_EOF);
- chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
- } else if (bytesRead < 0) {
- if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
- SetFlag(chanPtr->state, CHANNEL_BLOCKED);
- result = EAGAIN;
- }
- Tcl_SetErrno(result);
}
return bytesRead;
}
@@ -465,18 +482,23 @@ ChanSeek(
* type and non-NULL.
*/
- if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) {
- return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
- offset, mode, errnoPtr);
- }
+ if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
+#ifndef TCL_NO_DEPRECATED
+ if (offset<LONG_MIN || offset>LONG_MAX) {
+ *errnoPtr = EOVERFLOW;
+ return TCL_INDEX_NONE;
+ }
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
- *errnoPtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
+ offset, mode, errnoPtr);
+#else
+ *errnoPtr = EINVAL;
+ return TCL_INDEX_NONE;
+#endif
}
- return Tcl_LongAsWide(Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
- Tcl_WideAsLong(offset), mode, errnoPtr));
+ return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
+ offset, mode, errnoPtr);
}
static inline void
@@ -557,7 +579,6 @@ TclInitIOSubsystem(void)
*-------------------------------------------------------------------------
*/
- /* ARGSUSED */
void
TclFinalizeIOSubsystem(void)
{
@@ -826,7 +847,7 @@ Tcl_CreateCloseHandler(
* callback. */
Tcl_CloseProc *proc, /* The callback routine to call when the
* channel will be closed. */
- ClientData clientData) /* Arbitrary data to pass to the close
+ void *clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
@@ -864,7 +885,7 @@ Tcl_DeleteCloseHandler(
* callback. */
Tcl_CloseProc *proc, /* The procedure for the callback to
* remove. */
- ClientData clientData) /* The callback data for the callback to
+ void *clientData) /* The callback data for the callback to
* remove. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
@@ -963,7 +984,7 @@ GetChannelTable(
static void
DeleteChannelTable(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
Tcl_HashTable *hTblPtr; /* The hash table. */
@@ -1216,7 +1237,7 @@ Tcl_UnregisterChannel(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -1457,7 +1478,7 @@ Tcl_GetChannel(
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE);
+ *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE);
}
return (Tcl_Channel) chanPtr;
@@ -1493,23 +1514,22 @@ TclGetChannelFromObj(
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
- (void)flags;
if (interp == NULL) {
return TCL_ERROR;
}
- if (objPtr->typePtr == &chanObjType) {
+ ChanGetInternalRep(objPtr, resPtr);
+ if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
- resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1;
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
@@ -1526,26 +1546,25 @@ TclGetChannelFromObj(
if (chan == NULL) {
if (resPtr) {
- FreeChannelInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
- /* Re-use the ResolvedCmdName struct */
- Tcl_Release((ClientData) resPtr->statePtr);
+ /*
+ * Re-use the ResolvedCmdName struct.
+ */
+ Tcl_Release((void *) resPtr->statePtr);
} else {
- TclFreeIntRep(objPtr);
-
resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr;
- objPtr->typePtr = &chanObjType;
+ resPtr->refCount = 0;
+ ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
- Tcl_Preserve((ClientData) statePtr);
+ Tcl_Preserve((void *) statePtr);
resPtr->interp = interp;
resPtr->epoch = statePtr->epoch;
@@ -1553,7 +1572,7 @@ TclGetChannelFromObj(
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE);
+ *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
}
return TCL_OK;
@@ -1579,7 +1598,7 @@ Tcl_Channel
Tcl_CreateChannel(
const Tcl_ChannelType *typePtr, /* The channel type record. */
const char *chanName, /* Name of channel to record. */
- ClientData instanceData, /* Instance specific data. */
+ void *instanceData, /* Instance specific data. */
int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
{
@@ -1602,9 +1621,18 @@ Tcl_CreateChannel(
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
+#ifndef TCL_NO_DEPRECATED
if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) {
Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName);
}
+#else
+ if (Tcl_ChannelVersion(typePtr) < TCL_CHANNEL_VERSION_5) {
+ Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName);
+ }
+ if (typePtr->close2Proc == NULL) {
+ Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName);
+ }
+#endif
if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) {
Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName);
}
@@ -1614,9 +1642,11 @@ Tcl_CreateChannel(
if (NULL == typePtr->watchProc) {
Tcl_Panic("channel type %s must define watchProc", typePtr->typeName);
}
- if ((NULL!=typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
+#ifndef TCL_NO_DEPRECATED
+ if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName);
}
+#endif
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
@@ -1651,6 +1681,7 @@ Tcl_CreateChannel(
}
statePtr->channelName = tmp;
statePtr->flags = mask;
+ statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
@@ -1800,7 +1831,7 @@ Tcl_StackChannel(
const Tcl_ChannelType *typePtr,
/* The channel type record for the new
* channel. */
- ClientData instanceData, /* Instance specific data for the new
+ void *instanceData, /* Instance specific data for the new
* channel. */
int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
@@ -1846,7 +1877,7 @@ Tcl_StackChannel(
* --+---+---+---+----+
*/
- if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
+ if ((mask & GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE)) == 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"reading and writing both disallowed for channel \"%s\"",
@@ -2136,8 +2167,11 @@ Tcl_UnstackChannel(
/*
* Close and free the channel driver state.
+ * TIP #220: This is done with maximum privileges (as created).
*/
+ ResetFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
+ SetFlag(statePtr, statePtr->maxPerms);
result = ChanClose(chanPtr, interp);
ChannelFree(chanPtr);
@@ -2256,7 +2290,7 @@ Tcl_GetTopChannel(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetChannelInstanceData(
Tcl_Channel chan) /* Channel for which to return client data. */
{
@@ -2344,7 +2378,7 @@ Tcl_GetChannelMode(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of actual channel. */
- return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE));
+ return GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
}
/*
@@ -2395,10 +2429,10 @@ int
Tcl_GetChannelHandle(
Tcl_Channel chan, /* The channel to get file from. */
int direction, /* TCL_WRITABLE or TCL_READABLE. */
- ClientData *handlePtr) /* Where to store handle */
+ void **handlePtr) /* Where to store handle */
{
Channel *chanPtr; /* The actual channel. */
- ClientData handle;
+ void *handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
@@ -2417,6 +2451,54 @@ Tcl_GetChannelHandle(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RemoveChannelMode --
+ *
+ * Remove either read or write privileges from the channel.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May change the access mode of the channel.
+ * May leave an error message in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RemoveChannelMode(
+ Tcl_Interp* interp, /* The interp for an error message. Allowed to be NULL. */
+ Tcl_Channel chan, /* The channel which is modified. */
+ int mode) /* The access mode to drop from the channel */
+{
+ const char* emsg;
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of actual channel. */
+
+ if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
+ emsg = "Illegal mode value.";
+ goto error;
+ }
+ if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) {
+ emsg = "Bad mode, would make channel inacessible";
+ goto error;
+ }
+
+ ResetFlag(statePtr, mode);
+ return TCL_OK;
+
+ error:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Tcl_RemoveChannelMode error: %s. Channel: \"%s\"",
+ emsg, Tcl_GetChannelName((Tcl_Channel) chan)));
+ }
+ return TCL_ERROR;
+}
+
+/*
*---------------------------------------------------------------------------
*
* AllocChannelBuffer --
@@ -2461,7 +2543,7 @@ static void
PreserveChannelBuffer(
ChannelBuffer *bufPtr)
{
- if (bufPtr->refCount == 0) {
+ if (!bufPtr->refCount) {
Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
}
bufPtr->refCount++;
@@ -2528,7 +2610,7 @@ RecycleBuffer(
* This is to honor dynamic changes of the buffersize made by the user.
*/
- if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) {
+ if ((bufPtr->bufLength) != statePtr->bufSize + BUFFER_PADDING) {
ReleaseChannelBuffer(bufPtr);
return;
}
@@ -2638,7 +2720,7 @@ CheckForDeadChannel(
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unable to access channel: invalid channel", -1));
+ "unable to access channel: invalid channel", TCL_INDEX_NONE));
}
return 1;
}
@@ -2681,6 +2763,7 @@ FlushChannel(
int wroteSome = 0; /* Set to one if any data was written to the
* driver. */
+ int bufExists;
/*
* Prevent writing on a dead channel -- a channel that has been closed but
* not yet deallocated. This can occur if the exit handler for the channel
@@ -2835,7 +2918,7 @@ FlushChannel(
if (interp != NULL && !TclChanCaughtErrorBypass(interp,
(Tcl_Channel) chanPtr)) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj(Tcl_PosixError(interp), -1));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
/*
@@ -2849,8 +2932,8 @@ FlushChannel(
* queued.
*/
- DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
+ DiscardOutputQueued(statePtr);
break;
} else {
/*
@@ -2861,20 +2944,32 @@ FlushChannel(
wroteSome = 1;
}
- bufPtr->nextRemoved += written;
+ bufExists = bufPtr->refCount > 1;
+ ReleaseChannelBuffer(bufPtr);
+ if (bufExists) {
+ /* There is still a reference to this buffer other than the one
+ * this routine just released, meaning that final cleanup of the
+ * buffer hasn't been ordered by, e.g. by a reflected channel
+ * closing the channel from within one of its handler scripts (not
+ * something one would expecte, but it must be considered). Normal
+ * operations on the buffer can proceed.
+ */
- /*
- * If this buffer is now empty, recycle it.
- */
+ bufPtr->nextRemoved += written;
- if (IsBufferEmpty(bufPtr)) {
- statePtr->outQueueHead = bufPtr->nextPtr;
- if (statePtr->outQueueHead == NULL) {
- statePtr->outQueueTail = NULL;
+ /*
+ * If this buffer is now empty, recycle it.
+ */
+
+ if (IsBufferEmpty(bufPtr)) {
+ statePtr->outQueueHead = bufPtr->nextPtr;
+ if (statePtr->outQueueHead == NULL) {
+ statePtr->outQueueTail = NULL;
+ }
+ RecycleBuffer(statePtr, bufPtr, 0);
}
- RecycleBuffer(statePtr, bufPtr, 0);
}
- ReleaseChannelBuffer(bufPtr);
+
} /* Closes "while". */
/*
@@ -3353,12 +3448,12 @@ Tcl_SpliceChannel(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_Close(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan) /* The channel being closed. Must not be
- * referenced in any interpreter. */
+ * referenced in any interpreter. May be NULL,
+ * in which case this is a no-op. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
@@ -3398,7 +3493,7 @@ Tcl_Close(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3443,6 +3538,11 @@ Tcl_Close(
Tcl_ClearChannelHandlers(chan);
/*
+ * Cancel any outstanding timer.
+ */
+ Tcl_DeleteTimerHandler(statePtr->timer);
+
+ /*
* Invoke the registered close callbacks and delete their records.
*/
@@ -3460,6 +3560,7 @@ Tcl_Close(
* it anymore and this will help avoid deadlocks on some channel types.
*/
+#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) {
/* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
@@ -3467,6 +3568,12 @@ Tcl_Close(
result = 0;
}
}
+#else
+ result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
+ if ((result == EINVAL) || result == ENOTCONN) {
+ result = 0;
+ }
+#endif
/*
* The call to FlushChannel will flush any queued output and invoke the
@@ -3499,7 +3606,7 @@ Tcl_Close(
Tcl_SetErrno(stickyError);
if (interp != NULL) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj(Tcl_PosixError(interp), -1));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3514,10 +3621,10 @@ Tcl_Close(
result = flushcode;
}
if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
- && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
+ && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) {
Tcl_SetErrno(result);
Tcl_SetObjResult(interp,
- Tcl_NewStringObj(Tcl_PosixError(interp), -1));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
if (result != 0) {
return TCL_ERROR;
@@ -3530,24 +3637,21 @@ Tcl_Close(
*
* Tcl_CloseEx --
*
- * Closes one side of a channel, read or write.
+ * Closes one side of a channel, read or write, close all.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Closes one direction of the channel.
+ * Closes one direction of the channel, or do a full close.
*
* NOTE:
* Tcl_CloseEx closes the specified direction of the channel as far as
- * the user is concerned. The channel keeps existing however. You cannot
- * call this function to close the last possible direction of the
- * channel. Use Tcl_Close for that.
+ * the user is concerned. If flags = 0, this is equivalent to Tcl_Close.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CloseEx(
Tcl_Interp *interp, /* Interpreter for errors. */
@@ -3592,7 +3696,7 @@ Tcl_CloseEx(
if (chanPtr != statePtr->topChanPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "half-close not applicable to stack of transformations", -1));
+ "half-close not applicable to stack of transformations", TCL_INDEX_NONE));
return TCL_ERROR;
}
@@ -3602,7 +3706,7 @@ Tcl_CloseEx(
* opened for that direction).
*/
- if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) {
+ if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & flags)) {
const char *msg;
if (flags & TCL_CLOSE_READ) {
@@ -3621,11 +3725,11 @@ Tcl_CloseEx(
* That won't do.
*/
- if (statePtr->flags & CHANNEL_INCLOSE) {
+ if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3979,8 +4083,8 @@ Tcl_ClearChannelHandlers(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4007,14 +4111,14 @@ Tcl_Write(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
if (WriteBytes(chanPtr, src, srcLen) < 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
return srcLen;
}
@@ -4033,8 +4137,8 @@ Tcl_Write(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4056,7 +4160,7 @@ Tcl_WriteRaw(
int errorCode, written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (srcLen < 0) {
@@ -4089,8 +4193,8 @@ Tcl_WriteRaw(
* specified channel to the topmost channel in a stack.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4104,7 +4208,7 @@ Tcl_WriteChars(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* UTF-8 characters to queue in output
* buffer. */
- int len) /* Length of string in bytes, or < 0 for
+ int len) /* Length of string in bytes, or TCL_INDEX_NONE for
* strlen(). */
{
Channel *chanPtr = (Channel *) chan;
@@ -4113,7 +4217,7 @@ Tcl_WriteChars(
Tcl_Obj *objPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
chanPtr = statePtr->topChanPtr;
@@ -4158,8 +4262,8 @@ Tcl_WriteChars(
* line buffering mode.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno() will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno() will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4186,7 +4290,7 @@ Tcl_WriteObj(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (statePtr->encoding == NULL) {
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
@@ -4203,8 +4307,11 @@ WillWrite(
{
int inputBuffered;
- if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) &&
- ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
+ if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
+#ifndef TCL_NO_DEPRECATED
+ || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
+#endif
+ ) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
int ignore;
DiscardInputQueued(chanPtr->state, 0);
@@ -4223,11 +4330,13 @@ WillRead(
DiscardInputQueued(chanPtr->state, 0);
Tcl_SetErrno(EINVAL);
- return -1;
+ return TCL_INDEX_NONE;
}
- if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
- && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
-
+ if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
+#ifndef TCL_NO_DEPRECATED
+ || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
+#endif
+ ) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
/*
* CAVEAT - The assumption here is that FlushChannel() will push out
* the bytes of any writes that are in progress. Since this is a
@@ -4239,7 +4348,7 @@ WillRead(
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
}
return 0;
@@ -4256,7 +4365,7 @@ WillRead(
* ready e.g. if it contains a newline and we are in line buffering mode.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If TCL_INDEX_NONE,
* Tcl_GetErrno will return the error code.
*
* Side effects:
@@ -4285,6 +4394,21 @@ Write(
}
/*
+ * Transfer encoding nocomplain/strict option to the encoding flags
+ */
+
+ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) {
+ statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT;
+#ifdef TCL_NO_DEPRECATED
+ } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) {
+ statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN;
+#endif
+ } else {
+ statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ }
+
+ /*
* Write the terminated escape sequence even if srcLen is 0.
*/
@@ -4320,7 +4444,6 @@ Write(
bufPtr->nextAdded += saved;
saved = 0;
}
- PreserveChannelBuffer(bufPtr);
dst = InsertPoint(bufPtr);
dstLen = SpaceLeft(bufPtr);
@@ -4335,7 +4458,24 @@ Write(
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+ /*
+ * See io-75.2, TCL bug 6978c01b65.
+ * Check, if an encoding error occured and should be reported to the
+ * script level.
+ * This happens, if a written character may not be represented by the
+ * current output encoding and strict encoding is active.
+ */
+
+ if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
+ encodingError = 1;
+ result = TCL_OK;
+ }
+
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
+ /*
+ * We're reading from invalid/incomplete UTF-8.
+ */
+
encodingError = 1;
result = TCL_OK;
}
@@ -4406,8 +4546,7 @@ Write(
if (IsBufferFull(bufPtr)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- ReleaseChannelBuffer(bufPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
flushed += statePtr->bufSize;
@@ -4426,18 +4565,19 @@ Write(
needNlFlush = 0;
}
}
- ReleaseChannelBuffer(bufPtr);
}
if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
}
+ UpdateInterest(chanPtr);
+
if (encodingError) {
- Tcl_SetErrno(EINVAL);
- return -1;
+ Tcl_SetErrno(EILSEQ);
+ return TCL_INDEX_NONE;
}
return total;
}
@@ -4450,8 +4590,8 @@ Write(
* Reads a complete line of input from the channel into a Tcl_DString.
*
* Results:
- * Length of line read (in characters) or -1 if error, EOF, or blocked.
- * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
+ * Length of line read (in characters) or TCL_INDEX_NONE if error, EOF, or blocked.
+ * If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error code for the
* error or condition that occurred.
*
* Side effects:
@@ -4491,8 +4631,8 @@ Tcl_Gets(
* converted to UTF-8 using the encoding specified by the channel.
*
* Results:
- * Number of characters accumulated in the object or -1 if error,
- * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error
+ * Number of characters accumulated in the object or TCL_INDEX_NONE if error,
+ * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error
* code for the error or condition that occurred.
*
* Side effects:
@@ -4515,13 +4655,20 @@ Tcl_GetsObj(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
+ int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
+ int oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return TCL_INDEX_NONE;
+ }
+
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4536,7 +4683,7 @@ Tcl_GetsObj(
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4584,6 +4731,21 @@ Tcl_GetsObj(
}
/*
+ * Transfer encoding nocomplain/strict option to the encoding flags
+ */
+
+ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) {
+ statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT;
+#ifdef TCL_NO_DEPRECATED
+ } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN;
+#endif
+ } else {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ }
+
+ /*
* Object used by FilterInputBytes to keep track of how much data has been
* consumed from the channel buffers.
*/
@@ -4875,6 +5037,7 @@ Tcl_GetsObj(
done:
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
@@ -4908,8 +5071,8 @@ Tcl_GetsObj(
* may be called when an -eofchar is set on the channel.
*
* Results:
- * Number of characters accumulated in the object or -1 if error,
- * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error
+ * Number of characters accumulated in the object or TCL_INDEX_NONE if error,
+ * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error
* code for the error or condition that occurred.
*
* Side effects:
@@ -4931,8 +5094,9 @@ TclGetsObjBinary(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
- int rawLen, byteLen, eolChar;
+ int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
+ int rawLen, byteLen, oldLength;
+ int eolChar;
unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;
/*
@@ -5056,12 +5220,12 @@ TclGetsObjBinary(
if ((dst == dstEnd) && (byteLen == oldLength)) {
/*
* If we didn't append any bytes before encountering EOF,
- * caller needs to see -1.
+ * caller needs to see TCL_INDEX_NONE.
*/
byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
CommonGetsCleanup(chanPtr);
- copiedTotal = -1;
+ copiedTotal = TCL_INDEX_NONE;
ResetFlag(statePtr, CHANNEL_BLOCKED);
goto done;
}
@@ -5150,7 +5314,7 @@ TclGetsObjBinary(
*/
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
- copiedTotal = -1;
+ copiedTotal = TCL_INDEX_NONE;
/*
* Update the notifier state so we don't block while there is still data
@@ -5184,10 +5348,9 @@ TclGetsObjBinary(
static void
FreeBinaryEncoding(
- ClientData dummy) /* Not used */
+ TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
@@ -5196,7 +5359,7 @@ FreeBinaryEncoding(
}
static Tcl_Encoding
-GetBinaryEncoding()
+GetBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -5340,11 +5503,32 @@ FilterInputBytes(
*gsPtr->dstPtr = dst;
}
gsPtr->state = statePtr->inputEncodingState;
+
+ /*
+ * Transfer encoding nocomplain/strict option to the encoding flags
+ */
+
+ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) {
+ statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT;
+#ifdef TCL_NO_DEPRECATED
+ } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN;
+#endif
+ } else {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ }
+
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE,
&statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead,
&gsPtr->bytesWrote, &gsPtr->charsWrote);
+ if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
+ SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
+ result = TCL_OK;
+ }
+
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
@@ -5564,7 +5748,7 @@ CommonGetsCleanup(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5590,7 +5774,7 @@ Tcl_Read(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
return DoRead(chanPtr, dst, bytesToRead, 0);
@@ -5609,7 +5793,7 @@ Tcl_Read(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5631,7 +5815,7 @@ Tcl_ReadRaw(
assert(bytesToRead > 0);
if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -5685,13 +5869,7 @@ Tcl_ReadRaw(
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
- if (nread > 0) {
- /*
- * Successful read (short is OK) - add to bytes copied.
- */
-
- copied += nread;
- } else if (nread < 0) {
+ if (nread < 0) {
/*
* An error signaled. If CHANNEL_BLOCKED, then the error is not
* real, but an indication of blocked state. In that case, retain
@@ -5703,8 +5881,14 @@ Tcl_ReadRaw(
*/
if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
- copied = -1;
+ copied = TCL_INDEX_NONE;
}
+ } else if (nread > 0) {
+ /*
+ * Successful read (short is OK) - add to bytes copied.
+ */
+
+ copied += nread;
} else {
/*
* nread == 0. Driver is at EOF. Let that state filter up.
@@ -5727,7 +5911,7 @@ Tcl_ReadRaw(
* object.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5741,7 +5925,7 @@ Tcl_ReadChars(
Tcl_Channel chan, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
int toRead, /* Maximum number of characters to store, or
- * -1 to read all available data (up to EOF or
+ * TCL_INDEX_NONE to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
@@ -5765,7 +5949,7 @@ Tcl_ReadChars(
*/
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
return DoReadChars(chanPtr, objPtr, toRead, appendFlag);
@@ -5783,7 +5967,7 @@ Tcl_ReadChars(
* object.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5797,7 +5981,7 @@ DoReadChars(
Channel *chanPtr, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
int toRead, /* Maximum number of characters to store, or
- * -1 to read all available data (up to EOF or
+ * TCL_INDEX_NONE to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
@@ -5817,7 +6001,11 @@ DoReadChars(
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
- if (appendFlag == 0) {
+ if (appendFlag) {
+ if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) {
+ binaryMode = 0;
+ }
+ } else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
@@ -5835,6 +6023,12 @@ DoReadChars(
}
}
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ /* TODO: We don't need this call? */
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return -1;
+ }
/*
* Early out when next read will see eofchar.
*
@@ -5883,7 +6077,7 @@ DoReadChars(
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
for (copied = 0; (unsigned) toRead > 0; ) {
- copiedNow = -1;
+ copiedNow = TCL_INDEX_NONE;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
copiedNow = ReadBytes(statePtr, objPtr, toRead);
@@ -5923,7 +6117,7 @@ DoReadChars(
}
if (result != 0) {
if (!GotFlag(statePtr, CHANNEL_BLOCKED)) {
- copied = -1;
+ copied = TCL_INDEX_NONE;
}
break;
}
@@ -5961,6 +6155,7 @@ DoReadChars(
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
@@ -5984,7 +6179,7 @@ DoReadChars(
*
* Results:
* The return value is the number of bytes appended to the object, or
- * -1 to indicate that zero bytes were read due to an EOF.
+ * TCL_INDEX_NONE to indicate that zero bytes were read due to an EOF.
*
* Side effects:
* The storage of bytes in objPtr can cause (re-)allocation of memory.
@@ -6053,7 +6248,7 @@ ReadChars(
* allocated to hold data, not how many bytes
* of data have been stored in the object. */
int charsToRead, /* Maximum number of characters to store, or
- * -1 to get all available characters.
+ * TCL_INDEX_NONE to get all available characters.
* Characters are obtained from the first
* buffer in the queue -- even if this number
* is larger than the number of characters
@@ -6077,7 +6272,8 @@ ReadChars(
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
- int numBytes, srcLen = BytesLeft(bufPtr);
+ int numBytes;
+ int srcLen = BytesLeft(bufPtr);
/*
* One src byte can yield at most one character. So when the number of
@@ -6109,6 +6305,21 @@ ReadChars(
}
/*
+ * Transfer encoding nocomplain/strict option to the encoding flags
+ */
+
+ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) {
+ statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT;
+#ifdef TCL_NO_DEPRECATED
+ } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN;
+#endif
+ } else {
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT;
+ }
+
+ /*
* This routine is burdened with satisfying several constraints. It cannot
* append more than 'charsToRead` chars onto objPtr. This is measured
* after encoding and translation transformations are completed. There is
@@ -6153,6 +6364,11 @@ ReadChars(
flags, &statePtr->inputEncodingState,
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
+ if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) {
+ SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
+ code = TCL_OK;
+ }
+
/*
* Perform the translation transformation in place. Read no more than
* the dstDecoded bytes the encoding transformation actually produced.
@@ -6180,12 +6396,12 @@ ReadChars(
* the stopping, but the value of dstRead does not include it.
*
* Also rather bizarre, our caller can only notice an EOF
- * condition if we return the value -1 as the number of chars
+ * condition if we return the value TCL_INDEX_NONE as the number of chars
* read. This forces us to perform a 2-call dance where the
* first call can read all the chars up to the eof char, and
* the second call is solely for consuming the encoded eof
* char then pointed at by src so that we can return that
- * magic -1 value. This seems really wasteful, especially
+ * magic TCL_INDEX_NONE value. This seems really wasteful, especially
* since the first decoding pass of each call is likely to
* decode many bytes beyond that eof char that's all we care
* about.
@@ -6200,7 +6416,7 @@ ReadChars(
*/
Tcl_SetObjLength(objPtr, numBytes);
- return -1;
+ return TCL_INDEX_NONE;
}
{
@@ -6288,7 +6504,7 @@ ReadChars(
return 1;
}
- } else if (statePtr->flags & CHANNEL_EOF) {
+ } else if (GotFlag(statePtr, CHANNEL_EOF)) {
/*
* The bare \r is the only char and we will never read a
* subsequent char to make the determination.
@@ -6328,7 +6544,7 @@ ReadChars(
* bytes demanded by the Tcl_ExternalToUtf() call!
*/
- dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1);
+ dstLimit = TclUtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1);
statePtr->flags = savedFlags;
statePtr->inputEncodingFlags = savedIEFlags;
statePtr->inputEncodingState = savedState;
@@ -6375,7 +6591,7 @@ ReadChars(
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
}
Tcl_SetObjLength(objPtr, numBytes);
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -6554,7 +6770,7 @@ TranslateInputEOL(
char *dst = dstStart;
int lesser;
- if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
+ if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) {
if (*src == '\n') { src++; srcLen--; }
ResetFlag(statePtr, INPUT_SAW_CR);
}
@@ -6606,7 +6822,7 @@ TranslateInputEOL(
* channel, at either the head or tail of the queue.
*
* Results:
- * The number of bytes stored in the channel, or -1 on error.
+ * The number of bytes stored in the channel, or TCL_INDEX_NONE on error.
*
* Side effects:
* Adds input to the input queue of a channel.
@@ -6642,7 +6858,7 @@ Tcl_Ungets(
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- len = -1;
+ len = TCL_INDEX_NONE;
goto done;
}
statePtr->flags = flags;
@@ -6827,24 +7043,21 @@ GetInput(
}
/*
- * WARNING: There was once a comment here claiming that it was
- * a bad idea to make another call to the inputproc of a channel
- * driver when EOF has already been detected on the channel. Through
- * much of Tcl's history, this warning was then completely negated
- * by having all (most?) read paths clear the EOF setting before
- * reaching here. So we had a guard that was never triggered.
+ * WARNING: There was once a comment here claiming that it was a bad idea
+ * to make another call to the inputproc of a channel driver when EOF has
+ * already been detected on the channel. Through much of Tcl's history,
+ * this warning was then completely negated by having all (most?) read
+ * paths clear the EOF setting before reaching here. So we had a guard
+ * that was never triggered.
+ *
+ * Don't be tempted to restore the guard. Even if EOF is set on the
+ * channel, continue through and call the inputproc again. This is the
+ * way to enable the ability to [read] again beyond the EOF, which seems a
+ * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683]
+ * and which may even be essential for channels representing things like
+ * ttys or other devices where the stream might take the logical form of a
+ * series of 'files' separated by an EOF condition.
*
- * Don't be tempted to restore the guard. Even if EOF is set on
- * the channel, continue through and call the inputproc again. This
- * is the way to enable the ability to [read] again beyond the EOF,
- * which seems a strange thing to do, but for which use cases exist
- * [Tcl Bug 5adc350683] and which may even be essential for channels
- * representing things like ttys or other devices where the stream
- * might take the logical form of a series of 'files' separated by
- * an EOF condition.
- */
-
- /*
* First check for more buffers in the pushback area of the topmost
* channel in the stack and use them. They can be the result of a
* transformation which went away without reading all the information
@@ -6888,7 +7101,7 @@ GetInput(
*/
if ((bufPtr != NULL)
- && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) {
+ && (bufPtr->bufLength != statePtr->bufSize + BUFFER_PADDING)) {
ReleaseChannelBuffer(bufPtr);
bufPtr = NULL;
}
@@ -6913,15 +7126,17 @@ GetInput(
PreserveChannelBuffer(bufPtr);
nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead);
+ ReleaseChannelBuffer(bufPtr);
if (nread < 0) {
result = Tcl_GetErrno();
} else {
result = 0;
- bufPtr->nextAdded += nread;
+ if (statePtr->inQueueTail != NULL) {
+ statePtr->inQueueTail->nextAdded += nread;
+ }
}
- ReleaseChannelBuffer(bufPtr);
return result;
}
@@ -6943,10 +7158,10 @@ GetInput(
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
Tcl_Seek(
Tcl_Channel chan, /* The channel on which to seek. */
- Tcl_WideInt offset, /* Offset to seek to. */
+ long long offset, /* Offset to seek to. */
int mode) /* Relative to which location to seek? */
{
Channel *chanPtr = (Channel *) chan;
@@ -6956,7 +7171,7 @@ Tcl_Seek(
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of device driver operations. */
- Tcl_WideInt curPos; /* Position on the device. */
+ long long curPos; /* Position on the device. */
int wasAsync; /* Was the channel nonblocking before the seek
* operation? If so, must restore to
* non-blocking mode after the seek. */
@@ -6987,7 +7202,11 @@ Tcl_Seek(
* defined. This means that the channel does not support seeking.
*/
- if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) {
+ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
+#ifndef TCL_NO_DEPRECATED
+ && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
+#endif
+ ) {
Tcl_SetErrno(EINVAL);
return -1;
}
@@ -7112,7 +7331,7 @@ Tcl_Seek(
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
Tcl_Tell(
Tcl_Channel chan) /* The channel to return pos for. */
{
@@ -7123,7 +7342,7 @@ Tcl_Tell(
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of calling device driver. */
- Tcl_WideInt curPos; /* Position on device. */
+ long long curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
return -1;
@@ -7151,7 +7370,11 @@ Tcl_Tell(
* defined. This means that the channel does not support seeking.
*/
- if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) {
+ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
+#ifndef TCL_NO_DEPRECATED
+ && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
+#endif
+ ) {
Tcl_SetErrno(EINVAL);
return -1;
}
@@ -7185,47 +7408,6 @@ Tcl_Tell(
/*
*---------------------------------------------------------------------------
*
- * Tcl_SeekOld, Tcl_TellOld --
- *
- * Backward-compatibility versions of the seek/tell interface that do not
- * support 64-bit offsets. This interface is not documented or expected
- * to be supported indefinitely.
- *
- * Results:
- * As for Tcl_Seek and Tcl_Tell respectively, except truncated to
- * whatever value will fit in an 'int'.
- *
- * Side effects:
- * As for Tcl_Seek and Tcl_Tell respectively.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-Tcl_SeekOld(
- Tcl_Channel chan, /* The channel on which to seek. */
- int offset, /* Offset to seek to. */
- int mode) /* Relative to which location to seek? */
-{
- Tcl_WideInt wOffset, wResult;
-
- wOffset = Tcl_LongAsWide((long) offset);
- wResult = Tcl_Seek(chan, wOffset, mode);
- return (int) Tcl_WideAsLong(wResult);
-}
-
-int
-Tcl_TellOld(
- Tcl_Channel chan) /* The channel to return pos for. */
-{
- Tcl_WideInt wResult = Tcl_Tell(chan);
-
- return (int) Tcl_WideAsLong(wResult);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* Tcl_TruncateChannel --
*
* Truncate a channel to the given length.
@@ -7244,7 +7426,7 @@ Tcl_TellOld(
int
Tcl_TruncateChannel(
Tcl_Channel chan, /* Channel to truncate. */
- Tcl_WideInt length) /* Length to truncate it to. */
+ long long length) /* Length to truncate it to. */
{
Channel *chanPtr = (Channel *) chan;
Tcl_DriverTruncateProc *truncateProc =
@@ -7358,7 +7540,7 @@ CheckChannelErrors(
* Fail if the channel is not opened for desired operation.
*/
- if ((statePtr->flags & direction) == 0) {
+ if (GotFlag(statePtr, direction) == 0) {
Tcl_SetErrno(EACCES);
return -1;
}
@@ -7406,7 +7588,7 @@ Tcl_Eof(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
- return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
+ return (GotFlag(statePtr, CHANNEL_EOF) && !GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) ? 1 : 0;
}
/*
@@ -7680,17 +7862,17 @@ Tcl_BadChannelOption(
{
if (interp != NULL) {
const char *genericopt =
- "blocking buffering buffersize encoding eofchar translation";
+ "blocking buffering buffersize encoding eofchar nocomplainencoding strictencoding translation";
const char **argv;
int argc, i;
Tcl_DString ds;
Tcl_Obj *errObj;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, genericopt, -1);
+ Tcl_DStringAppend(&ds, genericopt, TCL_INDEX_NONE);
if (optionList && (*optionList)) {
TclDStringAppendLiteral(&ds, " ");
- Tcl_DStringAppend(&ds, optionList, -1);
+ Tcl_DStringAppend(&ds, optionList, TCL_INDEX_NONE);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
@@ -7878,6 +8060,31 @@ Tcl_GetChannelOption(
return TCL_OK;
}
}
+ if (len == 0 || HaveOpt(1, "-nocomplainencoding")) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding");
+ }
+#ifdef TCL_NO_DEPRECATED
+ Tcl_DStringAppendElement(dsPtr,
+ (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0");
+#else
+ Tcl_DStringAppendElement(dsPtr,
+ (flags & CHANNEL_ENCODING_STRICT) ? "0" : "1");
+#endif
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
+ if (len == 0 || HaveOpt(1, "-strictencoding")) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-strictencoding");
+ }
+ Tcl_DStringAppendElement(dsPtr,
+ (flags & CHANNEL_ENCODING_STRICT) ? "1" : "0");
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
if (len == 0 || HaveOpt(1, "-translation")) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-translation");
@@ -7974,7 +8181,7 @@ Tcl_SetChannelOption(
/* State info for channel */
size_t len; /* Length of optionName string. */
int argc;
- const char **argv;
+ const char **argv = NULL;
/*
* If the channel is in the middle of a background copy, fail.
@@ -7984,7 +8191,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to set channel options: background copy in"
- " progress", -1));
+ " progress", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -8035,7 +8242,7 @@ Tcl_SetChannelOption(
} else if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
- " full, line, or none", -1));
+ " full, line, or none", TCL_INDEX_NONE));
return TCL_ERROR;
}
return TCL_OK;
@@ -8076,26 +8283,29 @@ Tcl_SetChannelOption(
statePtr->inputEncodingFlags = TCL_ENCODING_START;
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
- ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
+ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
UpdateInterest(chanPtr);
return TCL_OK;
} else if (HaveOpt(2, "-eofchar")) {
- if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
+ if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) {
+ if (GotFlag(statePtr, TCL_READABLE)) {
+ statePtr->inEofChar = newValue[0];
+ }
+ statePtr->outEofChar = 0;
+ } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
- }
- if (argc == 0) {
+ } else if (argc == 0) {
statePtr->inEofChar = 0;
statePtr->outEofChar = 0;
} else if (argc == 1 || argc == 2) {
- int outIndex = (argc - 1);
int inValue = (int) argv[0][0];
- int outValue = (int) argv[outIndex][0];
+ int outValue = (argc == 2) ? (int) argv[1][0] : 0;
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
- " character", -1));
+ " character", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8110,7 +8320,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
- " one, or two elements", -1));
+ " one, or two elements", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8131,6 +8341,45 @@ Tcl_SetChannelOption(
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
return TCL_OK;
+ } else if (HaveOpt(1, "-nocomplainencoding")) {
+ int newMode;
+
+ if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (newMode) {
+ ResetFlag(statePtr, CHANNEL_ENCODING_STRICT);
+ SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN);
+ } else {
+#ifdef TCL_NO_DEPRECATED
+ ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN);
+#else
+ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT) != CHANNEL_ENCODING_STRICT) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -nocomplainencoding: only true allowed",
+ TCL_INDEX_NONE));
+ }
+ return TCL_ERROR;
+ }
+#endif
+ }
+ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
+ return TCL_OK;
+ } else if (HaveOpt(1, "-strictencoding")) {
+ int newMode;
+
+ if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (newMode) {
+ ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN);
+ SetFlag(statePtr, CHANNEL_ENCODING_STRICT);
+ } else {
+ ResetFlag(statePtr, CHANNEL_ENCODING_STRICT);
+ }
+ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
+ return TCL_OK;
} else if (HaveOpt(1, "-translation")) {
const char *readMode, *writeMode;
@@ -8148,7 +8397,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
- " element list", -1));
+ " element list", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8178,7 +8427,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
+ "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8228,7 +8477,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
+ "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8556,6 +8805,16 @@ UpdateInterest(
}
}
}
+
+ if (!statePtr->timer
+ && mask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ }
+
+
ChanWatch(chanPtr, mask);
}
@@ -8578,30 +8837,51 @@ UpdateInterest(
static void
ChannelTimerProc(
- ClientData clientData)
+ void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
+
+ /* State info for channel */
ChannelState *statePtr = chanPtr->state;
- /* State info for channel */
- if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
- && (statePtr->interestMask & TCL_READABLE)
- && (statePtr->inQueueHead != NULL)
- && IsBufferReady(statePtr->inQueueHead)) {
+ /* Preserve chanPtr to guard against deallocation in Tcl_NotifyChannel. */
+ TclChannelPreserve((Tcl_Channel)chanPtr);
+ Tcl_Preserve(statePtr);
+ statePtr->timer = NULL;
+ if (statePtr->interestMask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)
+ && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
+ ) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
-
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
- Tcl_Preserve(statePtr);
- Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
- Tcl_Release(statePtr);
- } else {
- statePtr->timer = NULL;
- UpdateInterest(chanPtr);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
}
+
+ /* The channel may have just been closed from within Tcl_NotifyChannel */
+ if (!GotFlag(statePtr, CHANNEL_INCLOSE)) {
+ if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
+ && (statePtr->interestMask & TCL_READABLE)
+ && (statePtr->inQueueHead != NULL)
+ && IsBufferReady(statePtr->inQueueHead)) {
+ /*
+ * Restart the timer in case a channel handler reenters the event loop
+ * before UpdateInterest gets called by Tcl_NotifyChannel.
+ */
+
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
+ } else {
+ UpdateInterest(chanPtr);
+ }
+ }
+
+ Tcl_Release(statePtr);
+ TclChannelRelease((Tcl_Channel)chanPtr);
}
/*
@@ -8635,7 +8915,7 @@ Tcl_CreateChannelHandler(
* handler. */
Tcl_ChannelProc *proc, /* Procedure to call for each selected
* event. */
- ClientData clientData) /* Arbitrary data to pass to proc. */
+ void *clientData) /* Arbitrary data to pass to proc. */
{
ChannelHandler *chPtr;
Channel *chanPtr = (Channel *) chan;
@@ -8666,7 +8946,7 @@ Tcl_CreateChannelHandler(
/*
* The remainder of the initialization below is done regardless of whether
- * or not this is a new record or a modification of an old one.
+ * this is a new record or a modification of an old one.
*/
chPtr->mask = mask;
@@ -8707,7 +8987,7 @@ Tcl_DeleteChannelHandler(
Tcl_Channel chan, /* The channel for which to remove the
* callback. */
Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */
- ClientData clientData) /* The client data in the callback to
+ void *clientData) /* The client data in the callback to
* delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -8913,21 +9193,20 @@ CreateScriptRecord(
void
TclChannelEventScriptInvoker(
- ClientData clientData, /* The script+interp record. */
- int mask) /* Not used. */
+ void *clientData, /* The script+interp record. */
+ TCL_UNUSED(int) /*mask*/)
{
- Tcl_Interp *interp; /* Interpreter in which to eval the script. */
- Channel *chanPtr; /* The channel for which this handler is
- * registered. */
- EventScriptRecord *esPtr; /* The event script + interpreter to eval it
+ EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
+ /* The event script + interpreter to eval it
* in. */
+ Channel *chanPtr = esPtr->chanPtr;
+ /* The channel for which this handler is
+ * registered. */
+ Tcl_Interp *interp = esPtr->interp;
+ /* Interpreter in which to eval the script. */
+ int mask = esPtr->mask;
int result; /* Result of call to eval script. */
- esPtr = (EventScriptRecord *)clientData;
- chanPtr = esPtr->chanPtr;
- mask = esPtr->mask;
- interp = esPtr->interp;
-
/*
* Be sure event executed in managed channel (covering bugs similar [f583715154]).
*/
@@ -8980,10 +9259,9 @@ TclChannelEventScriptInvoker(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FileEventObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
@@ -8997,7 +9275,6 @@ Tcl_FileEventObjCmd(
int mask;
static const char *const modeOptions[] = {"readable", "writable", NULL};
static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
- (void)dummy;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
@@ -9016,7 +9293,7 @@ Tcl_FileEventObjCmd(
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
- if ((statePtr->flags & mask) == 0) {
+ if (GotFlag(statePtr, mask) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s",
(mask == TCL_READABLE) ? "readable" : "writable"));
return TCL_ERROR;
@@ -9078,7 +9355,7 @@ Tcl_FileEventObjCmd(
static void
ZeroTransferTimerProc(
- ClientData clientData)
+ void *clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
@@ -9107,6 +9384,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9118,13 +9396,14 @@ TclCopyChannelOld(
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
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. */
+ long long toRead, /* Amount of data to copy, or -1 for all. */
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
Channel *inPtr = (Channel *) inChan;
@@ -9181,8 +9460,8 @@ TclCopyChannel(
* Make sure the output side is unbuffered.
*/
- outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED)
- | CHANNEL_UNBUFFERED;
+ ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED);
+ SetFlag(outStatePtr, CHANNEL_UNBUFFERED);
/*
* Test for conditions where we know we can just move bytes from input
@@ -9193,7 +9472,9 @@ TclCopyChannel(
moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
- && inStatePtr->encoding == outStatePtr->encoding;
+ && inStatePtr->encoding == outStatePtr->encoding
+ && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT
+ && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN;
/*
* Allocate a new CopyState to maintain info about the current copy in
@@ -9201,7 +9482,7 @@ TclCopyChannel(
* completed.
*/
- csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize);
+ csPtr = (CopyState *)ckalloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
@@ -9312,7 +9593,7 @@ MBError(
static void
MBEvent(
- ClientData clientData,
+ void *clientData,
int mask)
{
CopyState *csPtr = (CopyState *) clientData;
@@ -9391,13 +9672,13 @@ MBWrite(
if (bufPtr) {
/* Split the overflowing buffer in two */
int extra = (int) (inBytes - csPtr->toRead);
- /* Note that going with int for extra assumes that inBytes is not too
- * much over toRead to require a wide itself. If that gets violated
- * then the calculations involving extra must be made wide too.
- *
- * Noted with Win32/MSVC debug build treating the warning (possible of
- * data in __int64 to int conversion) as error.
- */
+ /* Note that going with int for extra assumes that inBytes is not too
+ * much over toRead to require a wide itself. If that gets violated
+ * then the calculations involving extra must be made wide too.
+ *
+ * Noted with Win32/MSVC debug build treating the warning (possible of
+ * data in long long to int conversion) as error.
+ */
bufPtr = AllocChannelBuffer(extra);
@@ -9495,7 +9776,8 @@ CopyData(
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
- int result = TCL_OK, size, sizeb;
+ int result = TCL_OK, size;
+ int sizeb;
Tcl_WideInt total;
const char *buffer;
int inBinary, outBinary, sameEncoding;
@@ -9519,7 +9801,9 @@ CopyData(
inBinary = (inStatePtr->encoding == NULL);
outBinary = (outStatePtr->encoding == NULL);
- sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);
+ sameEncoding = inStatePtr->encoding == outStatePtr->encoding
+ && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT
+ && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN;
if (!(inBinary || sameEncoding)) {
TclNewObj(bufObj);
@@ -9802,7 +10086,7 @@ CopyData(
*
* Results:
* The number of bytes actually stored (<= bytesToRead),
- * or -1 if there is an error in reading the channel. Use
+ * or TCL_INDEX_NONE if there is an error in reading the channel. Use
* Tcl_GetErrno() to retrieve the error code for the error
* that occurred.
*
@@ -9811,7 +10095,7 @@ CopyData(
* - EOF is reached on the channel; or
* - the channel is non-blocking, and we've read all we can
* without blocking.
- * - a channel reading error occurs (and we return -1)
+ * - a channel reading error occurs (and we return TCL_INDEX_NONE)
*
* Side effects:
* May cause input to be buffered.
@@ -9843,6 +10127,11 @@ DoRead(
* too. Keep on keeping on for now.
*/
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return -1;
+ }
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
@@ -9910,7 +10199,7 @@ DoRead(
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
assert(IsBufferFull(bufPtr));
@@ -9940,10 +10229,10 @@ DoRead(
}
/*
- * 1) We're @EOF because we saw eof char.
+ * 1) We're @EOF because we saw eof char, or there was an encoding error.
*/
- if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
+ if (GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)) {
break;
}
@@ -9961,7 +10250,7 @@ DoRead(
* There's no more buffered data...
*/
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
/*
* ...and there never will be.
*/
@@ -9969,7 +10258,7 @@ DoRead(
*p++ = '\r';
bytesToRead--;
bufPtr->nextRemoved++;
- } else if (statePtr->flags & CHANNEL_BLOCKED) {
+ } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
/*
* ...and we cannot get more now.
*/
@@ -10028,6 +10317,7 @@ DoRead(
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
@@ -10056,7 +10346,7 @@ DoRead(
static void
CopyEventProc(
- ClientData clientData,
+ void *clientData,
int mask)
{
(void) CopyData((CopyState *)clientData, mask);
@@ -10102,20 +10392,20 @@ StopCopy(
*/
nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING;
- if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) {
+ if (nonBlocking != GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->readPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
if (csPtr->readPtr != csPtr->writePtr) {
nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING;
- if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
+ if (nonBlocking != GotFlag(outStatePtr, CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->writePtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
}
ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
- outStatePtr->flags |=
- csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
+ SetFlag(outStatePtr,
+ csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED));
if (csPtr->cmdPtr) {
Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr);
@@ -10318,7 +10608,7 @@ Tcl_GetChannelNamesEx(
&& (pattern[2] == 'd'))) {
if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL)
&& (Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(pattern, -1)) != TCL_OK)) {
+ Tcl_NewStringObj(pattern, TCL_INDEX_NONE)) != TCL_OK)) {
goto error;
}
goto done;
@@ -10345,7 +10635,7 @@ Tcl_GetChannelNamesEx(
if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
(Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(name, -1)) != TCL_OK)) {
+ Tcl_NewStringObj(name, TCL_INDEX_NONE)) != TCL_OK)) {
error:
TclDecrRefCount(resultPtr);
return TCL_ERROR;
@@ -10526,6 +10816,7 @@ Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2)
|| (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) {
/*
@@ -10534,6 +10825,7 @@ Tcl_ChannelVersion(
*/
return TCL_CHANNEL_VERSION_1;
}
+#endif
return chanTypePtr->version;
}
@@ -10557,13 +10849,14 @@ Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
-
+#endif
return chanTypePtr->blockModeProc;
}
@@ -10583,6 +10876,7 @@ Tcl_ChannelBlockModeProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10590,6 +10884,7 @@ Tcl_ChannelCloseProc(
{
return chanTypePtr->closeProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10679,6 +10974,7 @@ Tcl_ChannelOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10686,6 +10982,7 @@ Tcl_ChannelSeekProc(
{
return chanTypePtr->seekProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10804,9 +11101,11 @@ Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
+#endif
return chanTypePtr->flushProc;
}
@@ -10831,9 +11130,11 @@ Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
+#endif
return chanTypePtr->handlerProc;
}
@@ -10858,9 +11159,11 @@ Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) {
return NULL;
}
+#endif
return chanTypePtr->wideSeekProc;
}
@@ -10886,9 +11189,11 @@ Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) {
return NULL;
}
+#endif
return chanTypePtr->threadActionProc;
}
@@ -10915,15 +11220,17 @@ Tcl_SetChannelErrorInterp(
Tcl_Obj *msg) /* Error message to store. */
{
Interp *iPtr = (Interp *) interp;
-
- if (iPtr->chanMsg != NULL) {
- TclDecrRefCount(iPtr->chanMsg);
- iPtr->chanMsg = NULL;
- }
+ Tcl_Obj *disposePtr = iPtr->chanMsg;
if (msg != NULL) {
iPtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(iPtr->chanMsg);
+ } else {
+ iPtr->chanMsg = NULL;
+ }
+
+ if (disposePtr != NULL) {
+ TclDecrRefCount(disposePtr);
}
return;
}
@@ -10951,15 +11258,17 @@ Tcl_SetChannelError(
Tcl_Obj *msg) /* Error message to store. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
-
- if (statePtr->chanMsg != NULL) {
- TclDecrRefCount(statePtr->chanMsg);
- statePtr->chanMsg = NULL;
- }
+ Tcl_Obj *disposePtr = statePtr->chanMsg;
if (msg != NULL) {
statePtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(statePtr->chanMsg);
+ } else {
+ statePtr->chanMsg = NULL;
+ }
+
+ if (disposePtr != NULL) {
+ TclDecrRefCount(disposePtr);
}
return;
}
@@ -10987,7 +11296,8 @@ static Tcl_Obj *
FixLevelCode(
Tcl_Obj *msg)
{
- int explicitResult, numOptions, lc, lcn;
+ int explicitResult, numOptions, lcn;
+ int lc;
Tcl_Obj **lv, **lvn;
int res, i, j, val, lignore, cignore;
int newlevel = -1, newcode = -1;
@@ -11004,7 +11314,7 @@ FixLevelCode(
* information. Hence an error means that we've got serious breakage.
*/
- res = TclListObjGetElements(NULL, msg, &lc, &lv);
+ res = TclListObjGetElementsM(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
@@ -11080,7 +11390,7 @@ FixLevelCode(
if (0 == strcmp(TclGetString(lv[i]), "-level")) {
if (newlevel >= 0) {
lvn[j++] = lv[i];
- lvn[j++] = Tcl_NewIntObj(newlevel);
+ lvn[j++] = Tcl_NewWideIntObj(newlevel);
newlevel = -1;
lignore = 1;
continue;
@@ -11090,7 +11400,7 @@ FixLevelCode(
} else if (0 == strcmp(TclGetString(lv[i]), "-code")) {
if (newcode >= 0) {
lvn[j++] = lv[i];
- lvn[j++] = Tcl_NewIntObj(newcode);
+ lvn[j++] = Tcl_NewWideIntObj(newcode);
newcode = -1;
cignore = 1;
continue;
@@ -11232,11 +11542,11 @@ DupChannelInternalRep(
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- resPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- copyPtr->typePtr = srcPtr->typePtr;
+ ChanGetInternalRep(srcPtr, resPtr);
+ assert(resPtr);
+ ChanSetInternalRep(copyPtr, resPtr);
}
/*
@@ -11259,10 +11569,11 @@ static void
FreeChannelInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- objPtr->typePtr = NULL;
- if (--resPtr->refCount) {
+ ChanGetInternalRep(objPtr, resPtr);
+ assert(resPtr);
+ if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
@@ -11280,8 +11591,8 @@ DumpFlags(
char *str,
int flags)
{
- char buf[20];
int i = 0;
+ char buf[24];
#define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
@@ -11294,6 +11605,7 @@ DumpFlags(
ChanFlag('c', CHANNEL_CLOSED);
ChanFlag('E', CHANNEL_EOF);
ChanFlag('S', CHANNEL_STICKY_EOF);
+ ChanFlag('U', CHANNEL_ENCODING_ERROR);
ChanFlag('B', CHANNEL_BLOCKED);
ChanFlag('/', INPUT_SAW_CR);
ChanFlag('D', CHANNEL_DEAD);
diff --git a/generic/tclIO.h b/generic/tclIO.h
index eccc7a9..a69e990 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -36,12 +36,12 @@
*/
typedef struct ChannelBuffer {
- int refCount; /* Current uses count */
- int nextAdded; /* The next position into which a character
+ Tcl_Size refCount; /* Current uses count */
+ Tcl_Size nextAdded; /* The next position into which a character
* will be put in the buffer. */
- int nextRemoved; /* Position of next byte to be removed from
+ Tcl_Size nextRemoved; /* Position of next byte to be removed from
* the buffer. */
- int bufLength; /* How big is the buffer? */
+ Tcl_Size bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
@@ -50,7 +50,7 @@ typedef struct ChannelBuffer {
* structure. */
} ChannelBuffer;
-#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf)
+#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
/*
* How much extra space to allocate in buffer to hold bytes from previous
@@ -96,7 +96,7 @@ typedef struct EventScriptRecord {
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
- ClientData instanceData; /* Instance-specific data provided by creator
+ void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
@@ -113,7 +113,7 @@ typedef struct Channel {
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
- int refCount;
+ Tcl_Size refCount;
} Channel;
/*
@@ -163,7 +163,7 @@ typedef struct ChannelState {
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
- int refCount; /* How many interpreters hold references to
+ Tcl_Size refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
@@ -186,7 +186,7 @@ typedef struct ChannelState {
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
- int bufSize; /* What size buffers to allocate? */
+ Tcl_Size bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
struct CopyState *csPtrR; /* State of background copy for which channel
* is input, or NULL. */
@@ -214,8 +214,10 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
- int epoch; /* Used to test validity of stored channelname
+ size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
+ int maxPerms; /* TIP #220: Max access privileges
+ * the channel was created with. */
} ChannelState;
/*
@@ -269,14 +271,20 @@ typedef struct ChannelState {
* delivered for buffered data until
* the state of the channel
* changes. */
+#define CHANNEL_ENCODING_ERROR (1<<15) /* set if channel
+ * encountered an encoding error */
#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is
* being used. */
-
+#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option
+ * -nocomplainencoding is set to 1 */
+#define CHANNEL_ENCODING_STRICT (1<<18) /* set if option
+ * -strictencoding is set to 1 */
#define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed.
* Its structures are still live and
* usable, but it may not be closed
* again from within the close
* handler. */
+#define ENCODING_FAILINDEX (1<<20) /* Internal flag, fail on Invalid bytes only */
#define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed.
* No further Tcl-level write IO on
* the channel is allowed. */
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index f11a4ab..e8a534f 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -3,7 +3,7 @@
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,8 +15,8 @@
* Callback structure for accept callback in a TCP server.
*/
-typedef struct AcceptCallback {
- char *script; /* Script to invoke. */
+typedef struct {
+ Tcl_Obj *script; /* Script to invoke. */
Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
@@ -25,7 +25,7 @@ typedef struct AcceptCallback {
* It must be per-thread because of std channel limitations.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;
@@ -36,20 +36,15 @@ static Tcl_ThreadDataKey dataKey;
* Static functions for this file:
*/
-static void FinalizeIOCmdTSD(ClientData clientData);
-static void AcceptCallbackProc(ClientData callbackData,
- Tcl_Channel chan, char *address, int port);
-static int ChanPendingObjCmd(ClientData unused,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int ChanTruncateObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp,
- AcceptCallback *acceptCallbackPtr);
-static void TcpAcceptCallbacksDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
-static void TcpServerCloseProc(ClientData callbackData);
+static Tcl_ExitProc FinalizeIOCmdTSD;
+static Tcl_TcpAcceptProc AcceptCallbackProc;
+static Tcl_ObjCmdProc ChanPendingObjCmd;
+static Tcl_ObjCmdProc ChanTruncateObjCmd;
+static void RegisterTcpServerInterpCleanup(
+ Tcl_Interp *interp,
+ AcceptCallback *acceptCallbackPtr);
+static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc;
+static void TcpServerCloseProc(void *callbackData);
static void UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
@@ -72,7 +67,7 @@ static void UnregisterTcpServerInterpCleanupProc(
static void
FinalizeIOCmdTSD(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -100,10 +95,9 @@ FinalizeIOCmdTSD(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_PutsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -114,7 +108,6 @@ Tcl_PutsObjCmd(
int newline; /* Add a newline at end? */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
- ThreadSpecificData *tsdPtr;
switch (objc) {
case 2: /* [puts $x] */
@@ -139,7 +132,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[2];
string = objv[3];
break;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
@@ -161,7 +154,7 @@ Tcl_PutsObjCmd(
}
if (chanObjPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
@@ -228,10 +221,9 @@ Tcl_PutsObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FlushObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -293,10 +285,9 @@ Tcl_FlushObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_GetsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -344,7 +335,7 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- lineLen = -1;
+ lineLen = TCL_INDEX_NONE;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
@@ -352,7 +343,7 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen));
} else {
Tcl_SetObjResult(interp, linePtr);
}
@@ -378,10 +369,9 @@ Tcl_GetsObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ReadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -441,7 +431,7 @@ Tcl_ReadObjCmd(
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -456,7 +446,7 @@ Tcl_ReadObjCmd(
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
@@ -522,10 +512,9 @@ Tcl_ReadObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_SeekObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -561,7 +550,7 @@ Tcl_SeekObjCmd(
TclChannelPreserve(chan);
result = Tcl_Seek(chan, offset, mode);
- if (result == Tcl_LongAsWide(-1)) {
+ if (result == -1) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
@@ -598,10 +587,9 @@ Tcl_SeekObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_TellObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -661,10 +649,9 @@ Tcl_TellObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CloseObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -770,10 +757,9 @@ Tcl_CloseObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FconfigureObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -846,10 +832,9 @@ Tcl_FconfigureObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_EofObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -886,10 +871,9 @@ Tcl_EofObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ExecObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -899,12 +883,12 @@ Tcl_ExecObjCmd(
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
- int argc, background, i, index, keepNewline, result, skip, length;
- int ignoreStderr;
+ int argc, background, i, index, keepNewline, result, skip, ignoreStderr;
+ int length;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
- enum options {
+ enum execOptionsEnum {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
@@ -954,7 +938,7 @@ Tcl_ExecObjCmd(
*/
argc = objc - skip;
- argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
+ argv = (const char **)TclStackAlloc(interp, (argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
@@ -993,7 +977,7 @@ Tcl_ExecObjCmd(
TclNewObj(resultPtr);
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
- if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
+ if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
@@ -1054,10 +1038,9 @@ Tcl_ExecObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FblockedObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1101,10 +1084,9 @@ Tcl_FblockedObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_OpenObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1162,7 +1144,8 @@ Tcl_OpenObjCmd(
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
- int mode, seekFlag, cmdObjc, binary;
+ int mode, seekFlag, binary;
+ int cmdObjc;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
@@ -1225,20 +1208,19 @@ Tcl_OpenObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(
- ClientData clientData, /* Data which was passed when the assocdata
+ void *clientData, /* Data which was passed when the assocdata
* was registered. */
- Tcl_Interp *interp) /* Interpreter being deleted - not used. */
+ TCL_UNUSED(Tcl_Interp *))
{
- Tcl_HashTable *hTblPtr = clientData;
+ Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr);
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
@@ -1280,10 +1262,10 @@ RegisterTcpServerInterpCleanup(
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
- hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
- hTblPtr = ckalloc(sizeof(Tcl_HashTable));
+ hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
@@ -1326,7 +1308,7 @@ UnregisterTcpServerInterpCleanupProc(
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
- hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
@@ -1356,7 +1338,7 @@ UnregisterTcpServerInterpCleanupProc(
static void
AcceptCallbackProc(
- ClientData callbackData, /* The data stored when the callback was
+ void *callbackData, /* The data stored when the callback was
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
@@ -1364,7 +1346,7 @@ AcceptCallbackProc(
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
- AcceptCallback *acceptCallbackPtr = callbackData;
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
@@ -1373,15 +1355,22 @@ AcceptCallbackProc(
*/
if (acceptCallbackPtr->interp != NULL) {
- char portBuf[TCL_INTEGER_SPACE];
- char *script = acceptCallbackPtr->script;
Tcl_Interp *interp = acceptCallbackPtr->interp;
- int result;
+ Tcl_Obj *script, *objv[2];
+ int result = TCL_OK;
- Tcl_Preserve(script);
- Tcl_Preserve(interp);
+ objv[0] = acceptCallbackPtr->script;
+ objv[1] = Tcl_NewListObj(3, NULL);
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(
+ Tcl_GetChannelName(chan), -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewWideIntObj(port));
- TclFormatInt(portBuf, port);
+ script = Tcl_ConcatObj(2, objv);
+ Tcl_IncrRefCount(script);
+ Tcl_DecrRefCount(objv[1]);
+
+ Tcl_Preserve(interp);
Tcl_RegisterChannel(interp, chan);
/*
@@ -1391,8 +1380,9 @@ AcceptCallbackProc(
Tcl_RegisterChannel(NULL, chan);
- result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
- " ", address, " ", portBuf, NULL);
+ result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(script);
+
if (result != TCL_OK) {
Tcl_BackgroundException(interp, result);
Tcl_UnregisterChannel(interp, chan);
@@ -1406,7 +1396,6 @@ AcceptCallbackProc(
Tcl_UnregisterChannel(NULL, chan);
Tcl_Release(interp);
- Tcl_Release(script);
} else {
/*
* The interpreter has been deleted, so there is no useful way to use
@@ -1440,17 +1429,17 @@ AcceptCallbackProc(
static void
TcpServerCloseProc(
- ClientData callbackData) /* The data passed in the call to
+ void *callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
- AcceptCallback *acceptCallbackPtr = callbackData;
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
- Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
+ Tcl_DecrRefCount(acceptCallbackPtr->script);
ckfree(acceptCallbackPtr);
}
@@ -1473,24 +1462,27 @@ TcpServerCloseProc(
int
Tcl_SocketObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
- "-async", "-myaddr", "-myport", "-server", NULL
+ "-async", "-backlog", "-myaddr", "-myport", "-reuseaddr",
+ "-reuseport", "-server", NULL
};
- enum socketOptions {
- SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ enum socketOptionsEnum {
+ SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR,
+ SKT_REUSEPORT, SKT_SERVER
};
- int optionIndex, a, server = 0, port, myport = 0, async = 0;
- const char *host, *script = NULL, *myaddr = NULL;
+ int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1,
+ reusea = -1, backlog = -1;
+ unsigned int flags = 0;
+ const char *host, *port, *myaddr = NULL;
+ Tcl_Obj *script = NULL;
Tcl_Channel chan;
- if (TclpHasSockets(interp) != TCL_OK) {
- return TCL_ERROR;
- }
+ TclInitSockets();
for (a = 1; a < objc; a++) {
const char *arg = Tcl_GetString(objv[a]);
@@ -1502,7 +1494,7 @@ Tcl_SocketObjCmd(
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum socketOptions) optionIndex) {
+ switch ((enum socketOptionsEnum) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -1548,7 +1540,40 @@ Tcl_SocketObjCmd(
"no argument given for -server option", -1));
return TCL_ERROR;
}
- script = TclGetString(objv[a]);
+ script = objv[a];
+ break;
+ case SKT_REUSEADDR:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseaddr option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_REUSEPORT:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseport option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_BACKLOG:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -backlog option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[a], &backlog) != TCL_OK) {
+ return TCL_ERROR;
+ }
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1570,35 +1595,66 @@ Tcl_SocketObjCmd(
wrongNumArgs:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv,
- "?-myaddr addr? ?-myport myport? ?-async? host port");
+ "?-async? ?-myaddr addr? ?-myport myport? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
- "-server command ?-myaddr addr? port");
+ "-server command ?-backlog count? ?-myaddr addr? "
+ "?-reuseaddr boolean? ?-reuseport boolean? port");
return TCL_ERROR;
}
- if (a == objc-1) {
- if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
- &port) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
+ if (!server && (reusea != -1 || reusep != -1 || backlog != -1)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "options -backlog, -reuseaddr, and -reuseport are only valid "
+ "for servers", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the options to their default value if the user didn't override
+ * their value.
+ */
+
+ if (reusep == -1) {
+ reusep = 0;
+ }
+ if (reusea == -1) {
+ reusea = 1;
+ }
+
+ /*
+ * Build the bitset with the flags values.
+ */
+
+ if (reusea) {
+ flags |= TCL_TCPSERVER_REUSEADDR;
+ }
+ if (reusep) {
+ flags |= TCL_TCPSERVER_REUSEPORT;
+ }
+
+ /*
+ * All the arguments should have been parsed by now, 'a' points to the
+ * last one, the port number.
+ */
+
+ if (a != objc-1) {
goto wrongNumArgs;
}
+ port = TclGetString(objv[a]);
+
if (server) {
- AcceptCallback *acceptCallbackPtr =
- ckalloc(sizeof(AcceptCallback));
- unsigned len = strlen(script) + 1;
- char *copyScript = ckalloc(len);
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback));
- memcpy(copyScript, script, len);
- acceptCallbackPtr->script = copyScript;
+ Tcl_IncrRefCount(script);
+ acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
- chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
- acceptCallbackPtr);
+
+ chan = Tcl_OpenTcpServerEx(interp, port, host, flags, backlog,
+ AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
- ckfree(copyScript);
+ Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
@@ -1620,7 +1676,13 @@ Tcl_SocketObjCmd(
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
- chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
+ int portNum;
+
+ if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
@@ -1651,7 +1713,7 @@ Tcl_SocketObjCmd(
int
Tcl_FcopyObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1744,10 +1806,9 @@ Tcl_FcopyObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ChanPendingObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1755,7 +1816,7 @@ ChanPendingObjCmd(
Tcl_Channel chan;
int index, mode;
static const char *const options[] = {"input", "output", NULL};
- enum options {PENDING_INPUT, PENDING_OUTPUT};
+ enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT};
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
@@ -1771,19 +1832,19 @@ ChanPendingObjCmd(
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum pendingOptionsEnum) index) {
case PENDING_INPUT:
if (!(mode & TCL_READABLE)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
if (!(mode & TCL_WRITABLE)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan)));
}
break;
}
@@ -1809,7 +1870,7 @@ ChanPendingObjCmd(
static int
ChanTruncateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1844,7 +1905,7 @@ ChanTruncateObjCmd(
*/
length = Tcl_Tell(chan);
- if (length == Tcl_WideAsLong(-1)) {
+ if (length == -1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not determine current location in \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
@@ -1882,7 +1943,7 @@ ChanTruncateObjCmd(
static int
ChanPipeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1933,7 +1994,7 @@ ChanPipeObjCmd(
int
TclChannelNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index bbb0838..0e15280 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -4,8 +4,8 @@
* Implements a generic transformation exposing the underlying API at the
* script level. Contributed by Andreas Kupries.
*
- * Copyright (c) 2000 Ajuba Solutions
- * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com)
+ * Copyright © 2000 Ajuba Solutions
+ * Copyright © 1999-2000 Andreas Kupries (a.kupries@westend.com)
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,15 +22,15 @@
static int TransformBlockModeProc(ClientData instanceData,
int mode);
static int TransformCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int TransformClose2Proc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int TransformInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCodePtr);
static int TransformOutputProc(ClientData instanceData,
const char *buf, int toWrite, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
static int TransformSeekProc(ClientData instanceData, long offset,
int mode, int *errorCodePtr);
+#endif
static int TransformSetOptionProc(ClientData instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
@@ -41,8 +41,8 @@ static void TransformWatchProc(ClientData instanceData, int mask);
static int TransformGetFileHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static int TransformNotifyProc(ClientData instanceData, int mask);
-static Tcl_WideInt TransformWideSeekProc(ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
+static long long TransformWideSeekProc(ClientData instanceData,
+ long long offset, int mode, int *errorCodePtr);
/*
* Forward declarations of internal procedures. Secondly the procedures for
@@ -121,15 +121,19 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf,
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- TransformCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
+#ifndef TCL_NO_DEPRECATED
TransformSeekProc, /* Seek proc. */
+#else
+ NULL, /* Seek proc. */
+#endif
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
TransformGetFileHandleProc, /* Get OS handles out of channel. */
- TransformClose2Proc, /* close2proc */
+ TransformCloseProc, /* close2proc */
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up. */
@@ -213,7 +217,7 @@ struct TransformChannelData {
* a transformation of incoming data. Also
* serves as buffer of all data not yet
* consumed by the reader. */
- int refCount;
+ size_t refCount;
};
static void
@@ -227,7 +231,7 @@ static void
ReleaseData(
TransformChannelData *dataPtr)
{
- if (--dataPtr->refCount) {
+ if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
@@ -253,7 +257,6 @@ ReleaseData(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
TclChannelTransform(
Tcl_Interp *interp, /* Interpreter for result. */
@@ -271,7 +274,7 @@ TclChannelTransform(
return TCL_ERROR;
}
- if (TCL_OK != TclListObjLength(interp, cmdObjPtr, &objc)) {
+ if (TCL_OK != TclListObjLengthM(interp, cmdObjPtr, &objc)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("-command value is not a list", -1));
return TCL_ERROR;
@@ -518,7 +521,7 @@ TransformBlockModeProc(
/*
*----------------------------------------------------------------------
*
- * TransformCloseProc/TransformClose2Proc --
+ * TransformCloseProc --
*
* Trap handler. Called by the generic IO system during destruction of
* the transformation channel.
@@ -535,9 +538,14 @@ TransformBlockModeProc(
static int
TransformCloseProc(
ClientData instanceData,
- Tcl_Interp *interp)
+ Tcl_Interp *interp,
+ int flags)
{
- TransformChannelData *dataPtr = instanceData;
+ TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
/*
* Important: In this procedure 'dataPtr->self' already points to the
@@ -594,18 +602,6 @@ TransformCloseProc(
ReleaseData(dataPtr);
return TCL_OK;
}
-
-static int
-TransformClose2Proc(
- ClientData instanceData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return TransformCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -842,6 +838,7 @@ TransformOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
@@ -888,6 +885,7 @@ TransformSeekProc(
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -909,20 +907,22 @@ TransformSeekProc(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
- Tcl_WideInt offset, /* Size of movement. */
+ long long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
+#endif
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
- ClientData parentData = Tcl_GetChannelInstanceData(parent);
+ void *parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
@@ -932,10 +932,14 @@ TransformWideSeekProc(
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+ } else if (parentSeekProc) {
+ return parentSeekProc(parentData, 0, mode, errorCodePtr);
+#endif
+ } else {
+ *errorCodePtr = EINVAL;
+ return -1;
}
-
- return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode,
- errorCodePtr));
}
/*
@@ -963,25 +967,29 @@ TransformWideSeekProc(
* If we have a wide seek capability, we should stick with that.
*/
- if (parentWideSeekProc != NULL) {
- return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
- }
+ if (parentWideSeekProc == NULL) {
+ /*
+ * We're transferring to narrow seeks at this point; this is a bit complex
+ * because we have to check whether the seek is possible first (i.e.
+ * whether we are losing information in truncating the bits of the
+ * offset). Luckily, there's a defined error for what happens when trying
+ * to go out of the representable range.
+ */
- /*
- * We're transferring to narrow seeks at this point; this is a bit complex
- * because we have to check whether the seek is possible first (i.e.
- * whether we are losing information in truncating the bits of the
- * offset). Luckily, there's a defined error for what happens when trying
- * to go out of the representable range.
- */
+#ifndef TCL_NO_DEPRECATED
+ if (offset<LONG_MIN || offset>LONG_MAX) {
+ *errorCodePtr = EOVERFLOW;
+ return -1;
+ }
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
- *errorCodePtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return parentSeekProc(parentData, offset,
+ mode, errorCodePtr);
+#else
+ *errorCodePtr = EINVAL;
+ return -1;
+#endif
}
-
- return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset),
- mode, errorCodePtr));
+ return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
@@ -1087,7 +1095,6 @@ TransformGetOptionProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TransformWatchProc(
ClientData instanceData, /* Channel to watch. */
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 7ea50c8..ec82fc5 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -10,7 +10,7 @@
*
* See TIP #219 for the specification of this functionality.
*
- * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
+ * Copyright © 2004-2005 ActiveState, a divison of Sophos
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,31 +31,35 @@
* Signatures of all functions used in the C layer of the reflection.
*/
-static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
+static int ReflectClose(void *clientData,
Tcl_Interp *interp, int flags);
-static int ReflectInput(ClientData clientData, char *buf,
+static int ReflectInput(void *clientData, char *buf,
int toRead, int *errorCodePtr);
-static int ReflectOutput(ClientData clientData, const char *buf,
+static int ReflectOutput(void *clientData, const char *buf,
int toWrite, int *errorCodePtr);
-static void ReflectWatch(ClientData clientData, int mask);
-static int ReflectBlock(ClientData clientData, int mode);
-#ifdef TCL_THREADS
-static void ReflectThread(ClientData clientData, int action);
+static void ReflectWatch(void *clientData, int mask);
+static int ReflectBlock(void *clientData, int mode);
+#if TCL_THREADS
+static void ReflectThread(void *clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
-static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
+static int ReflectEventDelete(Tcl_Event *ev, void *cd);
#endif
-static Tcl_WideInt ReflectSeekWide(ClientData clientData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
-static int ReflectSeek(ClientData clientData, long offset,
+static long long ReflectSeekWide(void *clientData,
+ long long offset, int mode, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+static int ReflectSeek(void *clientData, long offset,
int mode, int *errorCodePtr);
-static int ReflectGetOption(ClientData clientData,
+#endif
+static int ReflectGetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-static int ReflectSetOption(ClientData clientData,
+static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
+static int ReflectTruncate(void *clientData,
+ long long length);
+static void TimerRunRead(void *clientData);
+static void TimerRunWrite(void *clientData);
/*
* The C layer channel type/driver definition used by the reflection.
@@ -64,25 +68,29 @@ static int ReflectSetOption(ClientData clientData,
static const Tcl_ChannelType tclRChannelType = {
"tclrchannel", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- ReflectClose, /* Close channel, clean instance data */
+ TCL_CLOSE2PROC, /* Close channel, clean instance data */
ReflectInput, /* Handle read request */
ReflectOutput, /* Handle write request */
+#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. NULL'able */
+#else
+ NULL,
+#endif
ReflectSetOption, /* Set options. NULL'able */
ReflectGetOption, /* Get options. NULL'able */
ReflectWatch, /* Initialize notifier */
NULL, /* Get OS handle from the channel. NULL'able */
- ReflectClose2, /* No close2 support. NULL'able */
+ ReflectClose, /* 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 */
-#ifdef TCL_THREADS
+#if TCL_THREADS
ReflectThread, /* thread action, tracking owner */
#else
- NULL, /* thread action */
+ NULL, /* thread action */
#endif
- NULL /* truncate */
+ ReflectTruncate /* Truncate. NULL'able */
};
/*
@@ -98,7 +106,7 @@ typedef struct {
* interpreter/thread containing its Tcl
* command is gone.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
@@ -113,6 +121,17 @@ typedef struct {
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
+ Tcl_TimerToken readTimer; /*
+ A token for the timer that is scheduled in
+ order to call Tcl_NotifyChannel when the
+ channel is readable
+ */
+ Tcl_TimerToken writeTimer; /*
+ A token for the timer that is scheduled in
+ order to call Tcl_NotifyChannel when the
+ channel is writable
+ */
+
/*
* Note regarding the usage of timers.
*
@@ -122,11 +141,9 @@ typedef struct {
*
* See 'rechan', 'memchan', etc.
*
- * Here this is _not_ required. Interest in events is posted to the Tcl
- * level via 'watch'. And posting of events is possible from the Tcl level
- * as well, via 'chan postevent'. This means that the generation of all
- * events, fake or not, timer based or not, is completely in the hands of
- * the Tcl level. Therefore no timer here.
+ * A timer is used here as well in order to ensure at least on pass through
+ * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
+ * ef28eb1f1516.
*/
} ReflectedChannel;
@@ -171,6 +188,7 @@ static const char *const methodNames[] = {
"initialize", /* */
"read", /* OPT */
"seek", /* OPT */
+ "truncate", /* OPT */
"watch", /* */
"write", /* OPT */
NULL
@@ -184,6 +202,7 @@ typedef enum {
METH_INIT,
METH_READ,
METH_SEEK,
+ METH_TRUNCATE,
METH_WATCH,
METH_WRITE
} MethodName;
@@ -193,7 +212,8 @@ typedef enum {
(FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH))
#define NULLABLE_METHODS \
(FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \
- FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL))
+ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \
+ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE))
#define RANDW \
(TCL_READABLE | TCL_WRITABLE)
@@ -202,7 +222,7 @@ typedef enum {
#define NEGIMPL(a,b)
#define HAS(x,f) ((x) & FLAG(f))
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Thread specific types and structures.
*
@@ -223,7 +243,8 @@ typedef enum {
ForwardedBlock,
ForwardedSetOpt,
ForwardedGetOpt,
- ForwardedGetOptAll
+ ForwardedGetOptAll,
+ ForwardedTruncate
} ForwardedOperation;
/*
@@ -237,7 +258,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
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
@@ -286,6 +307,10 @@ struct ForwardParamGetOpt {
const char *name; /* Name of option to get, maybe NULL */
Tcl_DString *value; /* Result */
};
+struct ForwardParamTruncate {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ Tcl_WideInt length; /* I: Length of file. */
+};
/*
* Now join all these together in a single union for convenience.
@@ -300,6 +325,7 @@ typedef union ForwardParam {
struct ForwardParamBlock block;
struct ForwardParamSetOpt setOpt;
struct ForwardParamGetOpt getOpt;
+ struct ForwardParamTruncate truncate;
} ForwardParam;
/*
@@ -312,7 +338,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
@@ -349,7 +375,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected channels owned by this thread. This is the
* per-thread version of the per-interpreter map.
@@ -382,7 +408,7 @@ TCL_DECLARE_MUTEX(rcForwardMutex)
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
-static void SrcExitProc(ClientData clientData);
+static void SrcExitProc(void *clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
@@ -409,7 +435,7 @@ static void SrcExitProc(ClientData clientData);
static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
static ReflectedChannelMap * GetThreadReflectedChannelMap(void);
-static void DeleteThreadReflectedChannelMap(ClientData clientData);
+static Tcl_ExitProc DeleteThreadReflectedChannelMap;
#endif /* TCL_THREADS */
@@ -436,8 +462,7 @@ static int InvokeTclMethod(ReflectedChannel *rcPtr,
Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
-static void DeleteReflectedChannelMap(ClientData clientData,
- Tcl_Interp *interp);
+static Tcl_InterpDeleteProc DeleteReflectedChannelMap;
static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
static void MarkDead(ReflectedChannel *rcPtr);
@@ -452,7 +477,7 @@ static const char *msg_read_toomuch = "{read delivered more than requested}";
static const char *msg_write_toomuch = "{write wrote more than requested}";
static const char *msg_write_nothing = "{write wrote nothing}";
static const char *msg_seek_beforestart = "{Tried to seek before origin}";
-#ifdef TCL_THREADS
+#if TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
#endif /* TCL_THREADS */
static const char *msg_send_dstlost = "{Owner lost}";
@@ -482,7 +507,7 @@ static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo
int
TclChanCreateObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -508,7 +533,6 @@ TclChanCreateObjCmd(
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
- (void)dummy;
/*
* Syntax: chan create MODE CMDPREFIX
@@ -592,10 +616,10 @@ TclChanCreateObjCmd(
* Compare open mode against optional r/w.
*/
- if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -621,35 +645,35 @@ TclChanCreateObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"read\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"write\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -687,9 +711,14 @@ TclChanCreateObjCmd(
clonePtr->blockModeProc = NULL;
}
if (!(methods & FLAG(METH_SEEK))) {
+#ifndef TCL_NO_DEPRECATED
clonePtr->seekProc = NULL;
+#endif
clonePtr->wideSeekProc = NULL;
}
+ if (!(methods & FLAG(METH_TRUNCATE))) {
+ clonePtr->truncateProc = NULL;
+ }
chanPtr->typePtr = clonePtr;
}
@@ -708,7 +737,7 @@ TclChanCreateObjCmd(
Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
}
Tcl_SetHashValue(hPtr, chan);
-#ifdef TCL_THREADS
+#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
&isNew);
@@ -727,7 +756,7 @@ TclChanCreateObjCmd(
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
- ckfree((char*) rcPtr);
+ ckfree(rcPtr);
return TCL_ERROR;
#undef MODE
@@ -752,8 +781,8 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
-typedef struct ReflectEvent {
+#if TCL_THREADS
+typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
@@ -762,7 +791,7 @@ typedef struct ReflectEvent {
static int
ReflectEventRun(
Tcl_Event *ev,
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
/* OWNER thread
*
@@ -772,7 +801,6 @@ ReflectEventRun(
*/
ReflectEvent *e = (ReflectEvent *) ev;
- (void)flags;
Tcl_NotifyChannel(e->rcPtr->chan, e->events);
return 1;
@@ -781,7 +809,7 @@ ReflectEventRun(
static int
ReflectEventDelete(
Tcl_Event *ev,
- ClientData cd)
+ void *cd)
{
/* OWNER thread
*
@@ -801,7 +829,7 @@ ReflectEventDelete(
int
TclChanPostEventObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -830,7 +858,6 @@ TclChanPostEventObjCmd(
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)dummy;
/*
* Number of arguments...
@@ -921,11 +948,22 @@ TclChanPostEventObjCmd(
* We have the channel and the events to post.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
- Tcl_NotifyChannel(chan, events);
-#ifdef TCL_THREADS
+ if (events & TCL_READABLE) {
+ if (rcPtr->readTimer == NULL) {
+ rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ TimerRunRead, rcPtr);
+ }
+ }
+ if (events & TCL_WRITABLE) {
+ if (rcPtr->writeTimer == NULL) {
+ rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ TimerRunWrite, rcPtr);
+ }
+ }
+#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent));
@@ -956,8 +994,8 @@ TclChanPostEventObjCmd(
* XXX Actually, in that case the channel should be dead also !
*/
- Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(rcPtr->owner);
+ Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev,
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
}
#endif
@@ -972,6 +1010,24 @@ TclChanPostEventObjCmd(
#undef EVENT
}
+static void
+TimerRunRead(
+ void *clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->readTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
+}
+
+static void
+TimerRunWrite(
+ void *clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->writeTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
+}
+
/*
* Channel error message marshalling utilities.
*/
@@ -1016,7 +1072,7 @@ UnmarshallErrorResult(
* information; if we panic here, something has gone badly wrong already.
*/
- if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
@@ -1097,10 +1153,10 @@ TclChanCaughtErrorBypass(
/*
*----------------------------------------------------------------------
*
- * ReflectClose/ReflectClose2 --
+ * ReflectClose --
*
* This function is invoked when the channel is closed, to delete the
- * driver specific instance data.
+ * driver-specific instance data.
*
* Results:
* A posix error.
@@ -1113,8 +1169,9 @@ TclChanCaughtErrorBypass(
static int
ReflectClose(
- ClientData clientData,
- Tcl_Interp *interp)
+ void *clientData,
+ Tcl_Interp *interp,
+ int flags)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
int result; /* Result code for 'close' */
@@ -1124,12 +1181,16 @@ ReflectClose(
Tcl_HashEntry *hPtr; /* Entry in the above map */
const Tcl_ChannelType *tctPtr;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
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
+ * anymore. Threading is irrelevant as well. Simply clean up all
+ * the C level data structures and leave the Tcl level to the other
* finalization functions.
*/
@@ -1141,7 +1202,7 @@ ReflectClose(
* if lost?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1162,9 +1223,15 @@ ReflectClose(
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
+ ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
+ if (rcPtr->readTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->readTimer);
+ }
+ if (rcPtr->writeTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->writeTimer);
+ }
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
@@ -1173,7 +1240,7 @@ ReflectClose(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1220,7 +1287,7 @@ ReflectClose(
Tcl_DeleteHashEntry(hPtr);
}
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
@@ -1231,24 +1298,18 @@ ReflectClose(
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
- ((Channel *)rcPtr->chan)->typePtr = NULL;
+ ckfree(tctPtr);
+ ((Channel *)rcPtr->chan)->typePtr = NULL;
+ }
+ if (rcPtr->readTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->readTimer);
+ }
+ if (rcPtr->writeTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
-
-static int
-ReflectClose2(
- ClientData clientData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return ReflectClose(clientData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -1268,7 +1329,7 @@ ReflectClose2(
static int
ReflectInput(
- ClientData clientData,
+ void *clientData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -1283,7 +1344,7 @@ ReflectInput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1375,7 +1436,7 @@ ReflectInput(
static int
ReflectOutput(
- ClientData clientData,
+ void *clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -1389,7 +1450,7 @@ ReflectOutput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1502,10 +1563,10 @@ ReflectOutput(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
ReflectSeekWide(
- ClientData clientData,
- Tcl_WideInt offset,
+ void *clientData,
+ long long offset,
int seekMode,
int *errorCodePtr)
{
@@ -1518,7 +1579,7 @@ ReflectSeekWide(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1543,7 +1604,7 @@ ReflectSeekWide(
Tcl_Preserve(rcPtr);
- offObj = Tcl_NewWideIntObj(offset);
+ TclNewIntObj(offObj, offset);
baseObj = Tcl_NewStringObj(
(seekMode == SEEK_SET) ? "start" :
(seekMode == SEEK_CUR) ? "current" : "end", -1);
@@ -1578,9 +1639,10 @@ ReflectSeekWide(
goto stop;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
- ClientData clientData,
+ void *clientData,
long offset,
int seekMode,
int *errorCodePtr)
@@ -1592,9 +1654,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1615,7 +1678,7 @@ ReflectSeek(
static void
ReflectWatch(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1641,7 +1704,7 @@ ReflectWatch(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1687,7 +1750,7 @@ ReflectWatch(
static int
ReflectBlock(
- ClientData clientData,
+ void *clientData,
int nonblocking)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1699,7 +1762,7 @@ ReflectBlock(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1735,7 +1798,7 @@ ReflectBlock(
return errorNum;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1754,7 +1817,7 @@ ReflectBlock(
static void
ReflectThread(
- ClientData clientData,
+ void *clientData,
int action)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1791,7 +1854,7 @@ ReflectThread(
static int
ReflectSetOption(
- ClientData clientData, /* Channel to query */
+ void *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 */
@@ -1805,7 +1868,7 @@ ReflectSetOption(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1863,7 +1926,7 @@ ReflectSetOption(
static int
ReflectGetOption(
- ClientData clientData, /* Channel to query */
+ void *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 */
@@ -1884,9 +1947,9 @@ ReflectGetOption(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
- int opcode;
+ ForwardedOperation opcode;
ForwardParam p;
p.getOpt.name = optionName;
@@ -1957,7 +2020,7 @@ ReflectGetOption(
* result is a valid list. Nor that the list has an even number elements.
*/
- if (TclListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, resObj, &listc, &listv) != TCL_OK) {
goto error;
}
@@ -1974,7 +2037,7 @@ ReflectGetOption(
goto error;
} else {
int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
@@ -1998,6 +2061,73 @@ ReflectGetOption(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectTruncate --
+ *
+ * This function is invoked to truncate a channel's file size.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectTruncate(
+ void *clientData, /* Channel to query */
+ long long length) /* Length to truncate to. */
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ Tcl_Obj *lenObj;
+ int errorNum; /* EINVAL or EOK (success). */
+ Tcl_Obj *resObj; /* Result for 'truncate' */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#if TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.truncate.length = length;
+
+ ForwardOpToHandlerThread(rcPtr, ForwardedTruncate, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rcPtr->chan, &p);
+ return EINVAL;
+ }
+
+ return EOK;
+ }
+#endif
+
+ /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */
+
+ Tcl_Preserve(rcPtr);
+
+ lenObj = Tcl_NewWideIntObj(length);
+ Tcl_IncrRefCount(lenObj);
+
+ if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ errorNum = EINVAL;
+ } else {
+ errorNum = EOK;
+ }
+
+ Tcl_DecrRefCount(lenObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return errorNum;
+}
+
+/*
* Helpers. =========================================================
*/
@@ -2036,7 +2166,7 @@ EncodeEventMask(
int evIndex; /* Id of event for an element of the eventspec
* list. */
- if (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2138,7 +2268,7 @@ NewReflectedChannel(
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
- MethodName mn = METH_BLOCKING;
+ int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
@@ -2147,7 +2277,9 @@ NewReflectedChannel(
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
-#ifdef TCL_THREADS
+ rcPtr->readTimer = 0;
+ rcPtr->writeTimer = 0;
+#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
@@ -2157,7 +2289,7 @@ NewReflectedChannel(
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
- while (mn <= METH_WRITE) {
+ while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
Tcl_NewStringObj(methodNames[mn++], -1));
}
@@ -2347,7 +2479,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
int cmdLen;
- const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+ const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
@@ -2426,7 +2558,7 @@ ErrnoReturn(
if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK)
|| (code >= 0))) {
- if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) {
+ if (strcmp("EAGAIN", TclGetString(resObj)) == 0) {
code = -EAGAIN;
} else {
code = 0;
@@ -2463,8 +2595,7 @@ GetReflectedChannelMap(
if (rcmPtr == NULL) {
rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
- Tcl_SetAssocData(interp, RCMKEY,
- (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
+ Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr);
}
return rcmPtr;
}
@@ -2513,7 +2644,7 @@ MarkDead(
static void
DeleteReflectedChannelMap(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData;
@@ -2522,7 +2653,7 @@ DeleteReflectedChannelMap(
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
-#ifdef TCL_THREADS
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
@@ -2552,7 +2683,7 @@ DeleteReflectedChannelMap(
Tcl_DeleteHashTable(&rcmPtr->map);
ckfree(&rcmPtr->map);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
@@ -2635,10 +2766,12 @@ DeleteReflectedChannelMap(
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
+#else
+ (void)interp;
#endif
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2690,14 +2823,13 @@ GetThreadReflectedChannelMap(void)
static void
DeleteThreadReflectedChannelMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(void *))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
- (void)dummy;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2866,8 +2998,8 @@ ForwardOpToHandlerThread(
* Queue the event and poke the other thread's notifier.
*/
- Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(dst);
+ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr,
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
/*
* (*) Block until the handler thread has either processed the transfer or
@@ -2915,7 +3047,7 @@ ForwardOpToHandlerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
@@ -2944,7 +3076,6 @@ ForwardProc(
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)mask;
/*
* Ignore the event if no one is waiting for its result anymore.
@@ -3078,15 +3209,18 @@ 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);
+ Tcl_Obj *offObj;
+ Tcl_Obj *baseObj;
- Tcl_IncrRefCount(offObj);
- Tcl_IncrRefCount(baseObj);
+ TclNewIntObj(offObj, paramPtr->seek.offset);
+ baseObj = Tcl_NewStringObj(
+ (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
+ (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
- Tcl_Preserve(rcPtr);
+ Tcl_IncrRefCount(offObj);
+ Tcl_IncrRefCount(baseObj);
+
+ Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
paramPtr->seek.offset = -1;
@@ -3197,7 +3331,7 @@ ForwardProc(
int listc;
Tcl_Obj **listv;
- if (TclListObjGetElements(interp, resObj, &listc,
+ if (TclListObjGetElementsM(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
@@ -3215,7 +3349,7 @@ ForwardProc(
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
@@ -3226,6 +3360,19 @@ ForwardProc(
Tcl_Release(rcPtr);
break;
+ case ForwardedTruncate: {
+ Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length);
+
+ Tcl_IncrRefCount(lenObj);
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(lenObj);
+ break;
+ }
+
default:
/*
* Bad operation code.
@@ -3262,7 +3409,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -3314,7 +3461,7 @@ ForwardSetObjError(
Tcl_Obj *obj)
{
int len;
- const char *msgStr = Tcl_GetStringFromObj(obj, &len);
+ const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 26b6d99..3fe2585 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -10,7 +10,7 @@
*
* See TIP #230 for the specification of this functionality.
*
- * Copyright (c) 2007-2008 ActiveState.
+ * Copyright © 2007-2008 ActiveState.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,29 +31,29 @@
* Signatures of all functions used in the C layer of the reflection.
*/
-static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
+static int ReflectClose(void *clientData,
Tcl_Interp *interp, int flags);
-static int ReflectInput(ClientData clientData, char *buf,
+static int ReflectInput(void *clientData, char *buf,
int toRead, int *errorCodePtr);
-static int ReflectOutput(ClientData clientData, const char *buf,
+static int ReflectOutput(void *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,
+static void ReflectWatch(void *clientData, int mask);
+static int ReflectBlock(void *clientData, int mode);
+static long long ReflectSeekWide(void *clientData,
+ long long offset, int mode, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+static int ReflectSeek(void *clientData, long offset,
int mode, int *errorCodePtr);
-static int ReflectGetOption(ClientData clientData,
+#endif
+static int ReflectGetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-static int ReflectSetOption(ClientData clientData,
+static int ReflectSetOption(void *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);
+static int ReflectHandle(void *clientData, int direction,
+ void **handle);
+static int ReflectNotify(void *clientData, int mask);
/*
* The C layer channel type/driver definition used by the reflection.
@@ -62,15 +62,19 @@ static int ReflectNotify(ClientData clientData, int mask);
static const Tcl_ChannelType tclRTransformType = {
"tclrtransform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel. */
- ReflectClose, /* Close channel, clean instance data. */
+ TCL_CLOSE2PROC, /* Close channel, clean instance data. */
ReflectInput, /* Handle read request. */
ReflectOutput, /* Handle write request. */
+#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. */
+#else
+ NULL, /* Move location of access point. */
+#endif
ReflectSetOption, /* Set options. */
ReflectGetOption, /* Get options. */
ReflectWatch, /* Initialize notifier. */
ReflectHandle, /* Get OS handle from the channel. */
- ReflectClose2, /* No close2 support. NULL'able. */
+ ReflectClose, /* No close2 support. NULL'able. */
ReflectBlock, /* Set blocking/nonblocking. */
NULL, /* Flush channel. Not used by core.
* NULL'able. */
@@ -125,7 +129,7 @@ typedef struct {
* in the argv, see below. The separate field
* gives us direct access, needed when working
* with the reflection maps. */
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
#endif
@@ -218,7 +222,7 @@ typedef enum {
#define NEGIMPL(a,b)
#define HAS(x,f) ((x) & FLAG(f))
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Thread specific types and structures.
*
@@ -251,7 +255,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
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
@@ -296,7 +300,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
@@ -327,7 +331,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected transformations owned by this thread.
*/
@@ -359,7 +363,7 @@ TCL_DECLARE_MUTEX(rtForwardMutex)
static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
-static void SrcExitProc(ClientData clientData);
+static void SrcExitProc(void *clientData);
#define FreeReceivedError(p) \
do { \
@@ -398,7 +402,7 @@ static void ForwardSetObjError(ForwardParam *p,
Tcl_Obj *objPtr);
static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
static void DeleteThreadReflectedTransformMap(
- ClientData clientData);
+ void *clientData);
#endif /* TCL_THREADS */
#define SetChannelErrorStr(c,msgStr) \
@@ -424,7 +428,7 @@ static int InvokeTclMethod(ReflectedTransform *rtPtr,
Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
static ReflectedTransformMap * GetReflectedTransformMap(Tcl_Interp *interp);
-static void DeleteReflectedTransformMap(ClientData clientData,
+static void DeleteReflectedTransformMap(void *clientData,
Tcl_Interp *interp);
/*
@@ -436,7 +440,7 @@ static void DeleteReflectedTransformMap(ClientData clientData,
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
+#if TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
static const char *msg_send_dstlost = "{Owner lost}";
#endif /* TCL_THREADS */
@@ -454,7 +458,7 @@ static const char *msg_dstlost =
static void TimerKill(ReflectedTransform *rtPtr);
static void TimerSetup(ReflectedTransform *rtPtr);
-static void TimerRun(ClientData clientData);
+static void TimerRun(void *clientData);
static int TransformRead(ReflectedTransform *rtPtr,
int *errorCodePtr, Tcl_Obj *bufObj);
static int TransformWrite(ReflectedTransform *rtPtr,
@@ -499,7 +503,7 @@ static int TransformLimit(ReflectedTransform *rtPtr,
int
TclChanPushObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -526,7 +530,6 @@ TclChanPushObjCmd(
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
- (void)dummy;
/*
* Syntax: chan push CHANNEL CMDPREFIX
@@ -553,7 +556,7 @@ TclChanPushObjCmd(
*/
chanObj = objv[CHAN];
- parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode);
+ parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode);
if (parentChan == NULL) {
return TCL_ERROR;
}
@@ -604,10 +607,10 @@ TclChanPushObjCmd(
* through the mask. Compare open mode against optional r/w.
*/
- if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -618,7 +621,7 @@ TclChanPushObjCmd(
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
- Tcl_GetString(cmdObj),
+ TclGetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
@@ -632,7 +635,7 @@ TclChanPushObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -654,7 +657,7 @@ TclChanPushObjCmd(
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -665,14 +668,14 @@ TclChanPushObjCmd(
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -693,14 +696,14 @@ TclChanPushObjCmd(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
#endif /* TCL_THREADS */
@@ -745,7 +748,7 @@ TclChanPushObjCmd(
int
TclChanPopObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -763,7 +766,6 @@ TclChanPopObjCmd(
const char *chanId; /* Tcl level channel handle */
Tcl_Channel chan; /* Channel associated to the handle */
int mode; /* Channel r/w mode */
- (void)dummy;
/*
* Number of arguments...
@@ -841,7 +843,7 @@ UnmarshallErrorResult(
* information; if we panic here, something has gone badly wrong already.
*/
- if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
@@ -882,8 +884,9 @@ UnmarshallErrorResult(
static int
ReflectClose(
- ClientData clientData,
- Tcl_Interp *interp)
+ void *clientData,
+ Tcl_Interp *interp,
+ int flags)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int errorCode, errorCodeSet = 0;
@@ -894,6 +897,10 @@ ReflectClose(
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
@@ -911,7 +918,7 @@ ReflectClose(
* if lost?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -938,7 +945,7 @@ ReflectClose(
if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
if (!TransformDrain(rtPtr, &errorCode)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
@@ -952,7 +959,7 @@ ReflectClose(
if (HAS(rtPtr->methods, METH_FLUSH)) {
if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
@@ -968,7 +975,7 @@ ReflectClose(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1025,9 +1032,9 @@ ReflectClose(
* under a channel by deleting the owning thread.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -1037,18 +1044,6 @@ ReflectClose(
Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL);
}
-
-static int
-ReflectClose2(
- ClientData clientData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return ReflectClose(clientData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -1068,7 +1063,7 @@ ReflectClose2(
static int
ReflectInput(
- ClientData clientData,
+ void *clientData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -1261,7 +1256,7 @@ ReflectInput(
static int
ReflectOutput(
- ClientData clientData,
+ void *clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -1332,10 +1327,10 @@ ReflectOutput(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
ReflectSeekWide(
- ClientData clientData,
- Tcl_WideInt offset,
+ void *clientData,
+ long long offset,
int seekMode,
int *errorCodePtr)
{
@@ -1343,18 +1338,6 @@ ReflectSeekWide(
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
@@ -1398,17 +1381,23 @@ ReflectSeekWide(
* non-NULL...
*/
- if (Tcl_ChannelWideSeekProc(parent->typePtr) != NULL) {
- curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
- seekMode, errorCodePtr);
- } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
- offset > Tcl_LongAsWide(LONG_MAX)) {
- *errorCodePtr = EOVERFLOW;
- curPos = Tcl_LongAsWide(-1);
+ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
+#ifndef TCL_NO_DEPRECATED
+ if (offset < LONG_MIN || offset > LONG_MAX) {
+ *errorCodePtr = EOVERFLOW;
+ curPos = -1;
+ } else {
+ curPos = Tcl_ChannelSeekProc(parent->typePtr)(
+ parent->instanceData, offset, seekMode,
+ errorCodePtr);
+ }
+#else
+ *errorCodePtr = EINVAL;
+ curPos = -1;
+#endif
} else {
- curPos = Tcl_LongAsWide(Tcl_ChannelSeekProc(parent->typePtr)(
- parent->instanceData, Tcl_WideAsLong(offset), seekMode,
- errorCodePtr));
+ curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
+ seekMode, errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
@@ -1419,9 +1408,10 @@ ReflectSeekWide(
return curPos;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
- ClientData clientData,
+ void *clientData,
long offset,
int seekMode,
int *errorCodePtr)
@@ -1433,9 +1423,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1456,7 +1447,7 @@ ReflectSeek(
static void
ReflectWatch(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1507,7 +1498,7 @@ ReflectWatch(
static int
ReflectBlock(
- ClientData clientData,
+ void *clientData,
int nonblocking)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1540,7 +1531,7 @@ ReflectBlock(
static int
ReflectSetOption(
- ClientData clientData, /* Channel to query */
+ void *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 */
@@ -1582,7 +1573,7 @@ ReflectSetOption(
static int
ReflectGetOption(
- ClientData clientData, /* Channel to query */
+ void *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 */
@@ -1631,9 +1622,9 @@ ReflectGetOption(
static int
ReflectHandle(
- ClientData clientData,
+ void *clientData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1667,7 +1658,7 @@ ReflectHandle(
static int
ReflectNotify(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1762,7 +1753,7 @@ static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
- int mode,
+ TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
@@ -1770,7 +1761,6 @@ NewReflectedTransform(
int listc;
Tcl_Obj **listv;
int i;
- (void)mode;
rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform));
@@ -1779,7 +1769,7 @@ NewReflectedTransform(
rtPtr->chan = NULL;
rtPtr->methods = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtPtr->thread = Tcl_GetCurrentThread();
#endif
rtPtr->parent = parentChan;
@@ -1806,7 +1796,7 @@ NewReflectedTransform(
/* ASSERT: cmdpfxObj is a Tcl List */
- TclListObjGetElements(interp, cmdpfxObj, &listc, &listv);
+ TclListObjGetElementsM(interp, cmdpfxObj, &listc, &listv);
/*
* See [==] as well.
@@ -2055,7 +2045,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
int cmdLen;
- const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+ const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
@@ -2157,17 +2147,19 @@ GetReflectedTransformMap(
static void
DeleteReflectedTransformMap(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *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
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
+#else
+ (void)interp;
#endif /* TCL_THREADS */
/*
@@ -2194,7 +2186,7 @@ DeleteReflectedTransformMap(
Tcl_DeleteHashTable(&rtmPtr->map);
ckfree(&rtmPtr->map);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
@@ -2266,7 +2258,7 @@ DeleteReflectedTransformMap(
#endif /* TCL_THREADS */
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2318,14 +2310,13 @@ GetThreadReflectedTransformMap(void)
static void
DeleteThreadReflectedTransformMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(void *))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedTransformMap *rtmPtr; /* The map */
ForwardingResult *resultPtr;
- (void)dummy;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2463,8 +2454,8 @@ ForwardOpToOwnerThread(
* Queue the event and poke the other thread's notifier.
*/
- Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(dst);
+ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr,
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
/*
* (*) Block until the other thread has either processed the transfer or
@@ -2513,7 +2504,7 @@ ForwardOpToOwnerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
/*
* Notes regarding access to the referenced data.
@@ -2538,7 +2529,6 @@ ForwardProc(
/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)mask;
/*
* Ignore the event if no one is waiting for its result anymore.
@@ -2582,7 +2572,7 @@ ForwardProc(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
/*
@@ -2592,7 +2582,7 @@ ForwardProc(
*/
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedTransformArgs(rtPtr);
@@ -2769,7 +2759,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -2821,7 +2811,7 @@ ForwardSetObjError(
Tcl_Obj *obj)
{
int len;
- const char *msgStr = Tcl_GetStringFromObj(obj, &len);
+ const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
@@ -2909,7 +2899,7 @@ TimerSetup(
static void
TimerRun(
- ClientData clientData)
+ void *clientData)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -2969,7 +2959,7 @@ ResultClear(
return;
}
- ckfree((char *) rPtr->buf);
+ ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
@@ -3102,7 +3092,7 @@ TransformRead(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3158,7 +3148,7 @@ TransformWrite(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3224,7 +3214,7 @@ TransformDrain(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3274,7 +3264,7 @@ TransformFlush(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3329,7 +3319,7 @@ TransformClear(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3361,7 +3351,7 @@ TransformLimit(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 6413960..eaa9cc8 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -3,7 +3,7 @@
*
* Common routines used by all socket based channel types.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -12,24 +12,30 @@
#include "tclInt.h"
#if defined(_WIN32)
-/* On Windows, we need to do proper Unicode->UTF-8 conversion. */
+/*
+ * On Windows, we need to do proper Unicode->UTF-8 conversion.
+ */
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
Tcl_DString errorMsg; /* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#undef gai_strerror
-static const char *gai_strerror(int code) {
+static const char *
+gai_strerror(
+ int code)
+{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
- Tcl_DStringFree(&tsdPtr->errorMsg);
+ Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
} else {
+ Tcl_DStringInit(&tsdPtr->errorMsg);
tsdPtr->initialized = 1;
}
- Tcl_WinTCharToUtf((TCHAR *)gai_strerrorW(code), -1, &tsdPtr->errorMsg);
+ Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif
@@ -56,8 +62,8 @@ static const char *gai_strerror(int code) {
int
TclSockGetPort(
Tcl_Interp *interp,
- const char *string, /* Integer or service name */
- const char *proto, /* "tcp" or "udp", typically */
+ const char *string, /* Integer or service name */
+ const char *proto, /* "tcp" or "udp", typically */
int *portPtr) /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
@@ -126,7 +132,7 @@ TclSockMinimumBuffers(
}
len = sizeof(int);
getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
- (char *) &current, &len);
+ (char *) &current, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
@@ -154,15 +160,15 @@ TclSockMinimumBuffers(
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. */
+ 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;
@@ -181,30 +187,31 @@ TclCreateSocketAddress(
* Workaround for OSX's apparent inability to resolve "localhost", "0"
* when the loopback device is the only available network interface.
*/
+
if (host != NULL && port == 0) {
- portstring = NULL;
+ portstring = NULL;
} else {
- TclFormatInt(portbuf, port);
- portstring = portbuf;
+ TclFormatInt(portbuf, port);
+ portstring = portbuf;
}
(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]
+ * 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;
- }
- }
+ family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 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;
@@ -214,7 +221,7 @@ TclCreateSocketAddress(
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
* localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
- * using AI_ADDRCONFIG in situations where it works, is probably low,
+ * using AI_ADDRCONFIG is probably low even in situations where it works,
* we'll leave it out for now. After all, it is just an optimisation.
*
* Missing on: OpenBSD, NetBSD.
@@ -251,6 +258,7 @@ TclCreateSocketAddress(
*
* 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) {
@@ -283,6 +291,38 @@ TclCreateSocketAddress(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenTcpServer --
+ *
+ * Opens a TCP server socket and creates a channel around it.
+ *
+ * Results:
+ * The channel or NULL if failed. If an error occurred, an error message
+ * is left in the interp's result if interp is not NULL.
+ *
+ * Side effects:
+ * Opens a server socket and creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_OpenTcpServer(
+ Tcl_Interp *interp,
+ int port,
+ const char *host,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+{
+ char portbuf[TCL_INTEGER_SPACE];
+
+ TclFormatInt(portbuf, port);
+ return Tcl_OpenTcpServerEx(interp, portbuf, host, -1,
+ TCL_TCPSERVER_REUSEADDR, acceptProc, callbackData);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 8d5a6db..ae6bc56 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1,18 +1,15 @@
/*
* tclIOUtil.c --
*
- * This file contains the implementation of Tcl's generic filesystem
- * code, which supports a pluggable filesystem architecture allowing both
- * platform specific filesystems and 'virtual filesystems'. All
- * filesystem access should go through the functions defined in this
- * file. Most of this code was contributed by Vince Darley.
+ * Provides an interface for managing filesystems in Tcl, and also for
+ * creating a filesystem interface in Tcl arbitrary facilities. All
+ * filesystem operations are performed via this interface. Vince Darley
+ * is the primary author. Other signifiant contributors are Karl
+ * Lehenbauer, Mark Diekhans and Peter da Silva.
*
- * Parts of this file are based on code contributed by Karl Lehenbauer,
- * Mark Diekhans and Peter da Silva.
- *
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 2001-2004 Vincent Darley.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2001-2004 Vincent Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -33,42 +30,41 @@
/*
* struct FilesystemRecord --
*
- * A filesystem record is used to keep track of each filesystem currently
- * registered with the core, in a linked list.
+ * An item in a linked list of registered filesystems
*/
typedef struct FilesystemRecord {
- ClientData clientData; /* Client specific data for the new filesystem
+ ClientData clientData; /* Client-specific data for the filesystem
* (can be NULL) */
const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */
struct FilesystemRecord *nextPtr;
- /* The next filesystem registered to Tcl, or
- * NULL if no more. */
+ /* The next registered filesystem, or NULL to
+ * indicate the end of the list. */
struct FilesystemRecord *prevPtr;
- /* The previous filesystem registered to Tcl,
- * or NULL if no more. */
+ /* The previous filesystem, or NULL to indicate
+ * the ned of the list */
} FilesystemRecord;
/*
- * This structure holds per-thread private copy of the current directory
- * maintained by the global cwdPathPtr. This structure holds per-thread
- * private copies of some global data. This way we avoid most of the
- * synchronization calls which boosts performance, at cost of having to update
- * this information each time the corresponding epoch counter changes.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
- size_t cwdPathEpoch;
+ size_t cwdPathEpoch; /* Compared with the global cwdPathEpoch to
+ * determine whether cwdPathPtr is stale.
+ */
size_t filesystemEpoch;
- Tcl_Obj *cwdPathPtr;
+ Tcl_Obj *cwdPathPtr; /* A private copy of cwdPathPtr. Updated when
+ * the value is accessed and cwdPathEpoch has
+ * changed.
+ */
ClientData cwdClientData;
FilesystemRecord *filesystemList;
size_t claims;
} ThreadSpecificData;
/*
- * Prototypes for functions defined later in this file.
+ * Forward declarations.
*/
static Tcl_NRPostProc EvalFileCallback;
@@ -86,29 +82,12 @@ static void Disclaim(void);
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
- * because we have a few native filesystem functions (which are the same for
- * win/unix) in this file. There is no need to place them in tclInt.h, because
- * they are not (and should not be) used anywhere else.
- */
-
-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.
+ * Functions that provide native filesystem support. They are private and
+ * should be used only here. They should be called instead of calling Tclp...
+ * native filesystem functions. Others should use the Tcl_FS... functions
+ * which ensure correct and complete virtual filesystem support.
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
@@ -118,12 +97,21 @@ 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).
+ * Functions that support the native filesystem functions listed above. They
+ * are the same for win/unix, and not in tclInt.h because they are and should
+ * be used only here.
+ */
+
+MODULE_SCOPE const char *const tclpFileAttrStrings[];
+MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+
+
+/*
+ * These these functions are not static either because routines in the native
+ * (win/unix) directories call them or they are actually implemented in those
+ * directories. They should be called from outside Tcl's native filesystem
+ * routines. If we ever built the native filesystem support into a separate
+ * code library, this could actually be enforced.
*/
Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
@@ -143,11 +131,9 @@ 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!
+ * The native filesystem dispatch table. This could me made public but it
+ * should only be accessed by the functions it points to, or perhaps
+ * subordinate helper functions.
*/
const Tcl_Filesystem tclNativeFilesystem = {
@@ -190,13 +176,10 @@ const Tcl_Filesystem tclNativeFilesystem = {
};
/*
- * 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.
+ * An initial record in the linked list for the native filesystem. Remains at
+ * the tail of the list and is never freed. Currently the native filesystem is
+ * hard-coded. It may make sense to modify this to accomodate unconventional
+ * uses of Tcl that provide no native filesystem.
*/
static FilesystemRecord nativeFilesystemRecord = {
@@ -207,44 +190,42 @@ static FilesystemRecord nativeFilesystemRecord = {
};
/*
- * 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.
+ * Incremented each time the linked list of filesystems is modified. For
+ * multithreaded builds, invalidates all cached filesystem internal
+ * representations.
*/
static size_t theFilesystemEpoch = 1;
/*
- * 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.
+ * The linked list of filesystems. To minimize locking each thread maintains a
+ * local copy of this list.
+ *
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
- * Used to implement Tcl_FSGetCwd in a file-system independent way.
+ * A files-system indepent sense of the current directory.
*/
static Tcl_Obj *cwdPathPtr = NULL;
-static size_t cwdPathEpoch = 0;
+static size_t cwdPathEpoch = 0; /* The pathname of the current directory */
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
static Tcl_ThreadDataKey fsDataKey;
/*
- * 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.
+ * When a temporary copy of a file is created on the native filesystem in order
+ * to load the file, an FsDivertLoad structure is created to track both the
+ * actual unloadProc/clientData combination which was used, and the original and
+ * modified filenames. This makes it possible to correctly undo the entire
+ * operation in order to unload the library.
*/
-typedef struct FsDivertLoad {
+typedef struct {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
@@ -253,14 +234,14 @@ typedef struct FsDivertLoad {
} 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 string-based APIs that should be removed in a future release,
+ * perhaps in Tcl 9.
*/
/* Obsolete */
int
Tcl_Stat(
- const char *path, /* Path of file to stat (in current CP). */
+ const char *path, /* Pathname of file to stat (in current CP). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
@@ -275,8 +256,8 @@ Tcl_Stat(
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))
+ (((Tcl_WideInt)(x)) < LONG_MIN || \
+ ((Tcl_WideInt)(x)) > LONG_MAX)
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
@@ -347,7 +328,8 @@ Tcl_Stat(
/* Obsolete */
int
Tcl_Access(
- const char *path, /* Path of file to access (in current CP). */
+ const char *path, /* Pathname of file to access (in current CP).
+ */
int mode) /* Permission setting. */
{
int ret;
@@ -363,13 +345,12 @@ Tcl_Access(
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ Tcl_Interp *interp, /* Interpreter for error reporting. May be
* NULL. */
- const char *path, /* Name of file to open. */
+ const char *path, /* Pathname 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? */
+ int permissions) /* The modes to use if creating a new file. */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
@@ -413,9 +394,10 @@ Tcl_GetCwd(
int
Tcl_EvalFile(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- const char *fileName) /* Name of file to process. Tilde-substitution
- * will be performed on this name. */
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
+ const char *fileName) /* Pathname of the file containing the script.
+ * Performs Tilde-substitution on this
+ * pathaname. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
@@ -427,18 +409,18 @@ Tcl_EvalFile(
}
/*
- * Now move on to the basic filesystem implementation.
+ * The basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
- ThreadSpecificData *tsdPtr = cd;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/*
- * Trash the cwd copy.
+ * Discard the cwd copy.
*/
if (tsdPtr->cwdPathPtr != NULL) {
@@ -450,7 +432,7 @@ FsThrExitProc(
}
/*
- * Trash the filesystems cache.
+ * Discard the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
@@ -480,20 +462,20 @@ TclFSCwdIsNative(void)
*----------------------------------------------------------------------
*
* TclFSCwdPointerEquals --
- *
- * Check whether the current working directory is equal to the path
- * given.
+ * Determine whether the given pathname is equal to the current working
+ * directory.
*
* Results:
- * 1 (equal) or 0 (un-equal) as appropriate.
+ * 1 if equal, 0 otherwise.
*
* Side effects:
- * If the paths are equal, but are not the same object, this method will
- * modify the given pathPtrPtr to refer to the same object. In this case
- * the object pointed to by pathPtrPtr will have its refCount
- * decremented, and it will be adjusted to point to the cwd (with a new
- * refCount).
+ * Updates TSD if needed.
*
+ * Stores a pointer to the current directory in *pathPtrPtr if it is not
+ * already there and the current directory is not NULL.
+ *
+ * If *pathPtrPtr is not null its reference count is decremented
+ * before it is replaced.
*----------------------------------------------------------------------
*/
@@ -542,12 +524,12 @@ TclFSCwdPointerEquals(
int len1, len2;
const char *str1, *str2;
- str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
+ str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
- * They are equal, but different objects. Update so they will be
- * the same object in the future.
+ * The values are equal but the objects are different. Cache the
+ * current structure in place of the old one.
*/
Tcl_DecrRefCount(*pathPtrPtr);
@@ -590,13 +572,13 @@ FsRecacheFilesystemList(void)
}
/*
- * Refill the cache honouring the order.
+ * Refill the cache, honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
- tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
+ tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
@@ -609,6 +591,7 @@ FsRecacheFilesystemList(void)
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
+
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
@@ -636,8 +619,8 @@ FsGetFirstFilesystem(void)
}
/*
- * The epoch can be changed by filesystems being added or removed, by changing
- * the "system encoding" and by env(HOME) changing.
+ * The epoch can is changed when a filesystems is added or removed, when
+ * "system encoding" changes, and when env(HOME) changes.
*/
int
@@ -670,10 +653,9 @@ TclFSEpoch(void)
return tsdPtr->filesystemEpoch;
}
-
/*
- * If non-NULL, clientData is owned by us and must be freed later.
+ * If non-NULL, take posession of clientData and free it later.
*/
static void
@@ -686,7 +668,7 @@ FsUpdateCwd(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
- str = Tcl_GetStringFromObj(cwdObj, &len);
+ str = TclGetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
@@ -702,7 +684,7 @@ FsUpdateCwd(
cwdClientData = NULL;
} else {
/*
- * This must be stored as string obj!
+ * This must be stored as a string obj!
*/
cwdPathPtr = Tcl_NewStringObj(str, len);
@@ -738,17 +720,17 @@ FsUpdateCwd(
*
* TclFinalizeFilesystem --
*
- * Clean up the filesystem. After this, calls to all Tcl_FS... functions
- * will fail.
+ * Clean up the filesystem. After this, any call to a Tcl_FS... function
+ * fails.
*
- * We will later call TclResetFilesystem to restore the FS to a pristine
- * state.
+ * If TclResetFilesystem is called later, it restores the filesystem to a
+ * pristine state.
*
* Results:
* None.
*
* Side effects:
- * Frees any memory allocated by the filesystem.
+ * Frees memory allocated for the filesystem.
*
*----------------------------------------------------------------------
*/
@@ -759,8 +741,9 @@ TclFinalizeFilesystem(void)
FilesystemRecord *fsRecPtr;
/*
- * Assumption that only one thread is active now. Otherwise we would need
- * to put various mutexes around this code.
+ * Assume that only one thread is active. Otherwise mutexes would be needed
+ * around this code.
+ * TO DO: This assumption is false, isn't it?
*/
if (cwdPathPtr != NULL) {
@@ -782,7 +765,9 @@ TclFinalizeFilesystem(void)
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
- /* The native filesystem is static, so we don't free it. */
+ /*
+ * The native filesystem is static, so don't free it.
+ */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
@@ -795,8 +780,8 @@ TclFinalizeFilesystem(void)
filesystemList = NULL;
/*
- * Now filesystemList is NULL. This means that any attempt to use the
- * filesystem is likely to fail.
+ * filesystemList is now NULL. Any attempt to use the filesystem is likely
+ * to fail.
*/
#ifdef _WIN32
@@ -827,15 +812,6 @@ TclResetFilesystem(void)
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
-
-#ifdef _WIN32
- /*
- * Cleans up the win32 API filesystem proc lookup table. This must happen
- * very late in finalization so that deleting of copied dlls can occur.
- */
-
- TclWinResetInterfaces();
-#endif
}
/*
@@ -843,34 +819,31 @@ TclResetFilesystem(void)
*
* Tcl_FSRegister --
*
- * Insert the filesystem function table at the head of the list of
- * functions which are used during calls to all file-system operations.
- * The filesystem will be added even if it is already in the list. (You
- * can use Tcl_FSData to check if it is in the list, provided the
- * ClientData used was not NULL).
- *
- * Note that the filesystem handling is head-to-tail of the list. Each
- * filesystem is asked in turn whether it can handle a particular
- * request, until one of them says 'yes'. At that point no further
- * filesystems are asked.
+ * Prepends to the list of registered fileystems a new FilesystemRecord
+ * for the given Tcl_Filesystem, which is added even if it is already in
+ * the list. To determine whether the filesystem is already in the list,
+ * use Tcl_FSData().
*
- * In particular this means if you want to add a diagnostic filesystem
- * (which simply reports all fs activity), it must be at the head of the
- * list: i.e. it must be the last registered.
+ * Functions that use the list generally process it from head to tail and
+ * use the first filesystem that is suitable. Therefore, when adding a
+ * diagnostic filsystem (one which simply reports all fs activity), it
+ * must be at the head of the list. I.e. it must be the last one
+ * registered.
*
* Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
+ * TCL_OK, or 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 filesystems.
+ * Allocates memory for a filesystem record and modifies the list of
+ * registered filesystems.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(
- ClientData clientData, /* Client specific data for this fs. */
+ ClientData clientData, /* Client-specific data for this filesystem. */
const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
@@ -879,24 +852,11 @@ Tcl_FSRegister(
return TCL_ERROR;
}
- newFilesystemPtr = ckalloc(sizeof(FilesystemRecord));
+ newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
- /*
- * Is this lock and wait strictly speaking necessary? Since any iterators
- * out there will have grabbed a copy of the head of the list and be
- * iterating away from that, if we add a new element to the head of the
- * list, it can't possibly have any effect on any of their loops. In fact
- * it could be better not to wait, since we are adjusting the filesystem
- * epoch, any cached representations calculated by existing iterators are
- * going to have to be thrown away anyway.
- *
- * However, since registering and unregistering filesystems is a very rare
- * action, this is not a very important point.
- */
-
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
@@ -907,7 +867,7 @@ Tcl_FSRegister(
filesystemList = newFilesystemPtr;
/*
- * Increment the filesystem epoch counter, since existing paths might
+ * Increment the filesystem epoch counter since existing pathnames might
* conceivably now belong to different filesystems.
*/
@@ -924,28 +884,26 @@ Tcl_FSRegister(
*
* Tcl_FSUnregister --
*
- * Remove the passed filesystem from the list of filesystem function
- * tables. It also ensures that the built-in (native) filesystem is not
- * removable, although we may wish to change that decision in the future
- * to allow a smaller Tcl core, in which the native filesystem is not
- * used at all (we could, say, initialise Tcl completely over a network
- * connection).
+ * Removes the record for given filesystem from the list of registered
+ * filesystems. Refuses to remove the built-in (native) filesystem. This
+ * might be changed in the future to allow a smaller Tcl core in which the
+ * native filesystem is not used at all, e.g. initializing Tcl over a
+ * network connection.
*
* Results:
- * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * TCL_OK if the function pointer was successfully removed, or TCL_ERROR
* otherwise.
*
* Side effects:
- * Memory may be deallocated (or will be later, once no "path" objects
- * refer to this filesystem), but the list of registered filesystems is
- * updated immediately.
+ * The list of registered filesystems is updated. Memory for the
+ * corresponding FilesystemRecord is eventually freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnregister(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
+ const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -953,9 +911,9 @@ Tcl_FSUnregister(
Tcl_MutexLock(&filesystemMutex);
/*
- * Traverse the 'filesystemList' looking for the particular node whose
- * 'fsPtr' member matches 'fsPtr' and remove that one from the list.
- * Ensure that the "default" node cannot be removed.
+ * Traverse filesystemList in search of the record whose
+ * 'fsPtr' member matches 'fsPtr' and remove that record from the list.
+ * Do not revmoe the record for the native filesystem.
*/
fsRecPtr = filesystemList;
@@ -971,11 +929,9 @@ Tcl_FSUnregister(
}
/*
- * Increment the filesystem epoch counter, since existing paths
- * might conceivably now belong to different filesystems. This
- * should also ensure that paths which have cached the filesystem
- * which is about to be deleted do not reference that filesystem
- * (which would of course lead to memory exceptions).
+ * Each cached pathname could now belong to a different filesystem,
+ * so increment the filesystem epoch counter to ensure that cached
+ * information about the removed filesystem is not used.
*/
if (++theFilesystemEpoch == 0) {
@@ -999,52 +955,37 @@ Tcl_FSUnregister(
*
* Tcl_FSMatchInDirectory --
*
- * This routine is used by the globbing code to search a directory for
- * all files which match a given pattern. The appropriate function for
- * the filesystem to which pathPtr belongs will be called. If pathPtr
- * does not belong to any filesystem and if it is NULL or the empty
- * string, then we assume the pattern is to be matched in the current
- * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for
- * each filesystem from having to deal with this issue, we create a
- * pathPtr on the fly (equal to the cwd), and then remove it from the
- * results returned. This makes filesystems easy to write, since they can
- * assume the pathPtr passed to them is an ordinary path. In fact this
- * means we could remove such special case handling from Tcl's native
- * filesystems.
- *
- * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified
- * path of a single file/directory which must be checked for existence
- * and correct type.
+ * Search in the given pathname for files matching the given pattern.
+ * Used by [glob]. Processes just one pattern for one directory. Callers
+ * such as TclGlob and DoGlob implement manage the searching of multiple
+ * directories in cases such as
+ * glob -dir $dir -join * pkgIndex.tcl
*
* Results:
*
- * The return value is a standard Tcl result indicating whether an error
- * occurred in globbing. Error messages are placed in interp, but good
- * results are placed in the resultPtr given.
- *
- * Recursive searches, e.g.
- * glob -dir $dir -join * pkgIndex.tcl
- * which must recurse through each directory matching '*' are handled
- * internally by Tcl, by passing specific flags in a modified 'types'
- * parameter. This means the actual filesystem only ever sees patterns
- * which match in a single directory.
+ * TCL_OK, or TCL_ERROR
*
* Side effects:
- * The interpreter may have an error message inserted into it.
+ * resultPtr is populated, or in the case of an TCL_ERROR, an error message is
+ * set in the interpreter.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(
- Tcl_Interp *interp, /* Interpreter to receive error messages, but
- * 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. */
- Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. In particular the directory
- * flag is very important. */
+ Tcl_Interp *interp, /* Interpreter to receive error messages, or
+ * NULL */
+ Tcl_Obj *resultPtr, /* List that results are added to. */
+ Tcl_Obj *pathPtr, /* Pathname of directory to search. If NULL,
+ * the current working directory is used. */
+ const char *pattern, /* Pattern to match. If NULL, pathPtr must be
+ * a fully-specified pathname of a single
+ * file/directory which already exists and is
+ * of the correct type. */
+ Tcl_GlobTypeData *types) /* Specifies acceptable types.
+ * May be NULL. The directory flag is
+ * particularly significant. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
@@ -1052,10 +993,10 @@ Tcl_FSMatchInDirectory(
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
- * actually knows about mounts, this means we're being called
- * recursively by ourself. Return no matches.
+ * Currently external callers may not query mounts, which would be a
+ * valuable future step. This is the only routine that knows about
+ * mounts, so we're being called recursively by ourself. Return no
+ * matches.
*/
return TCL_OK;
@@ -1067,12 +1008,11 @@ Tcl_FSMatchInDirectory(
fsPtr = NULL;
}
- /*
- * Check if we've successfully mapped the path to a filesystem within
- * which to search.
- */
-
if (fsPtr != NULL) {
+ /*
+ * A corresponding filesystem was found. Search within it.
+ */
+
if (fsPtr->matchInDirectoryProc == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
@@ -1085,24 +1025,21 @@ Tcl_FSMatchInDirectory(
return ret;
}
- /*
- * If the path isn't empty, we have no idea how to match files in a
- * directory which belongs to no known filesystem.
- */
-
if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
+ /*
+ * There is a pathname but it belongs to no known filesystem. Mayday!
+ */
+
Tcl_SetErrno(ENOENT);
return -1;
}
/*
- * We have an empty or NULL path. This is defined to mean we must search
- * for files within the current 'cwd'. We therefore use that, but then
- * since the proc we call will return results which include the cwd we
- * must then trim it off the front of each path in the result. We choose
- * to deal with this here (in the generic code), since if we don't, every
- * single filesystem's implementation of Tcl_FSMatchInDirectory will have
- * to deal with it for us.
+ * The pathname is empty or NULL so search in the current working
+ * directory. matchInDirectoryProc prefixes each result with this
+ * directory, so trim it from each result. Deal with this here in the
+ * generic code because otherwise every filesystem implementation of
+ * Tcl_FSMatchInDirectory has to do it.
*/
cwd = Tcl_FSGetCwd(NULL);
@@ -1125,10 +1062,10 @@ Tcl_FSMatchInDirectory(
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
- * Note that we know resultPtr and tmpResultPtr are distinct.
+ * resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
- ret = TclListObjGetElements(interp, tmpResultPtr,
+ ret = TclListObjGetElementsM(interp, tmpResultPtr,
&resLength, &elemsPtr);
for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
@@ -1145,30 +1082,28 @@ Tcl_FSMatchInDirectory(
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
- *
- * This routine is used by the globbing code to take the results of a
- * directory listing and add any mounted paths to that listing. This is
- * required so that simple things like 'glob *' merge mounts and listings
- * correctly.
+ * Adds any mounted pathnames to a set of results so that simple things
+ * like 'glob *' merge mounts and listings correctly. Used by the
+ * Tcl_FSMatchInDirectory.
*
* Results:
* None.
*
* Side effects:
- * Modifies the resultPtr.
+ * Stores a result in resultPtr.
*
*----------------------------------------------------------------------
*/
static void
FsAddMountsToGlobResult(
- Tcl_Obj *resultPtr, /* The current list of matching paths; must
- * not be shared! */
- 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
- * flag is very important. */
+ Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must
+ * not be shared. */
+ Tcl_Obj *pathPtr, /* The directory that was searched. */
+ const char *pattern, /* Pattern to match mounts against. */
+ Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
+ * directory flag is particularly significant.
+ */
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
@@ -1178,10 +1113,10 @@ FsAddMountsToGlobResult(
return;
}
- if (TclListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
+ if (TclListObjLengthM(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
- if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
+ if (TclListObjLengthM(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i=0 ; i<mLength ; i++) {
@@ -1213,17 +1148,17 @@ FsAddMountsToGlobResult(
int len, mlen;
/*
- * We know mElt is absolute normalized and lies inside pathPtr, so
- * now we must add to the result the right representation of mElt,
- * i.e. the representation which is relative to pathPtr.
+ * mElt is normalized and lies inside pathPtr so
+ * add to the result the right representation of mElt,
+ * i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
- mount = Tcl_GetStringFromObj(mElt, &mlen);
- path = Tcl_GetStringFromObj(norm, &len);
+ mount = TclGetStringFromObj(mElt, &mlen);
+ path = TclGetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
@@ -1231,13 +1166,14 @@ FsAddMountsToGlobResult(
len--;
}
- len++; /* account for '/' in the mElt [Bug 1602539] */
+ len++; /* account for '/' in the mElt [Bug 1602539] */
+
+
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
/*
- * No need to increment gLength, since we don't want to compare
- * mounts against mounts.
+ * Not comparing mounts to mounts, so no need to increment gLength
*/
}
}
@@ -1251,63 +1187,56 @@ FsAddMountsToGlobResult(
*
* Tcl_FSMountsChanged --
*
- * Notify the filesystem that the available mounted filesystems (or
- * within any one filesystem type, the number or location of mount
- * points) have changed.
+ * Announecs that mount points have changed or that the system encoding
+ * has changed.
*
* Results:
* None.
*
* Side effects:
- * The global filesystem variable 'theFilesystemEpoch' is incremented.
- * The effect of this is to make all cached path representations invalid.
- * Clearly it should only therefore be called when it is really required!
- * There are a few circumstances when it should be called:
+ * The shared 'theFilesystemEpoch' is incremented, invalidating every
+ * exising cached internal representation of a pathname. Avoid calling
+ * Tcl_FSMountsChanged whenever possible. It must be called when:
*
- * (1) when a new filesystem is registered or unregistered. Strictly
- * speaking this is only necessary if the new filesystem accepts file
- * paths as is (normally the filesystem itself is really a shell which
- * hasn't yet had any mount points established and so its
- * 'pathInFilesystem' proc will always fail). However, for safety, Tcl
- * always calls this for you in these circumstances.
+ * (1) A filesystem is registered or unregistered. This is only necessary
+ * if the new filesystem accepts file pathnames as-is. Normally the
+ * filesystem is really a shell which doesn't yet have any mount points
+ * established and so its 'pathInFilesystem' routine always fails.
+ * However, for safety, Tcl calls 'Tcl_FSMountsChanged' each time a
+ * filesystem is registered or unregistered.
*
- * (2) when additional mount points are established inside any existing
- * filesystem (except the native fs)
+ * (2) An additional mount point is established inside an existing
+ * filesystem (except for the native file system; see note below).
*
- * (3) when any filesystem (except the native fs) changes the list of
- * available volumes.
+ * (3) A filesystem changes the list of available volumes (except for the
+ * native file system; see note below).
*
- * (4) when the mapping from a string representation of a file to a full,
- * normalized path changes. For example, if 'env(HOME)' is modified, then
- * any path containing '~' will map to a different filesystem location.
- * Therefore all such paths need to have their internal representation
- * invalidated.
+ * (4) The mapping from a string representation of a file to a full,
+ * normalized pathname changes. For example, if 'env(HOME)' is modified,
+ * then any pathname containing '~' maps to a different item, possibly in
+ * a different filesystem.
*
- * Tcl has no control over (2) and (3), so any registered filesystem must
- * make sure it calls this function when those situations occur.
+ * Tcl has no control over (2) and (3), so each registered filesystem must
+ * call Tcl_FSMountsChnaged in each of those circumstances.
*
- * (Note: the reason for the exception in 2,3 for the native filesystem
- * is that the native filesystem by default claims all unknown files even
- * if it really doesn't understand them or if they don't exist).
+ * The reason for the exception in 2,3 for the native filesystem is that
+ * the native filesystem claims every file without determining whether
+ * whether the file exists, or even whether the pathname makes sense.
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(
- const Tcl_Filesystem *fsPtr)
-{
+ TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/)
/*
- * We currently don't do anything with this parameter. We could in the
- * future only invalidate files for this filesystem or otherwise take more
- * advanced action.
+ * fsPtr is currently unused. In the future it might invalidate files for
+ * a particular filesystem, or take some other more advanced action.
*/
-
- (void)fsPtr;
-
+{
/*
- * Increment the filesystem epoch counter, since existing paths might now
- * belong to different filesystems.
+ * Increment the filesystem epoch to invalidate every existing cached
+ * internal representation.
*/
Tcl_MutexLock(&filesystemMutex);
@@ -1322,13 +1251,11 @@ Tcl_FSMountsChanged(
*
* Tcl_FSData --
*
- * Retrieve the clientData field for the filesystem given, or NULL if
- * that filesystem is not registered.
+ * Retrieves the clientData member of the given filesystem.
*
* Results:
- * A clientData value, or NULL. Note that if the filesystem was
- * registered with a NULL clientData field, this function will return
- * that NULL value.
+ * A clientData value, or NULL if the given filesystem is not registered.
+ * The clientData value itself may also be NULL.
*
* Side effects:
* None.
@@ -1338,15 +1265,14 @@ Tcl_FSMountsChanged(
ClientData
Tcl_FSData(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to query. */
+ const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of
+ * registered filesystems. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
- * Traverse the list of filesystems look for a particular one. If found,
- * return that filesystem's clientData (originally provided when calling
- * Tcl_FSRegister).
+ * Find the filesystem in and retrieve its clientData.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
@@ -1364,27 +1290,24 @@ Tcl_FSData(
*
* TclFSNormalizeToUniquePath --
*
- * Takes a path specification containing no ../, ./ sequences, and
- * converts it into a unique path for the given platform. On Unix, this
- * means the path must be free of symbolic links/aliases, and on Windows
- * it means we want the long form, with that long form's case-dependence
- * (which gives us a unique, case-dependent path).
+ * Converts the given pathname, containing no ../, ./ components, into a
+ * unique pathname for the given platform. On Unix the resulting pathname
+ * is free of symbolic links/aliases, and on Windows it is the long
+ * case-preserving form.
+ *
*
* Results:
- * The pathPtr is modified in place. The return value is the last byte
- * offset which was recognised in the path string.
+ * Stores the resulting pathname in pathPtr and returns the offset of the
+ * last byte processed in pathPtr.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special notes:
* If the filesystem-specific normalizePathProcs can re-introduce ../, ./
- * sequences into the path, then this function will not return the
- * correct result. This may be possible with symbolic links on unix.
+ * components into the pathname, this function does not return the correct
+ * result. This may be possible with symbolic links on unix.
*
- * Important assumption: if startAt is non-zero, it must point to a
- * directory separator that we know exists and is already normalized (so
- * it is important not to point to the char just after the separator).
*
*---------------------------------------------------------------------------
*/
@@ -1392,44 +1315,79 @@ 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, /* An Pathname to normalize in-place. Must be
+ * unshared. */
+ int startAt) /* Offset the string of pathPtr to start at.
+ * Must either be 0 or offset of a directory
+ * separator at the end of a pathname part that
+ * is already normalized, I.e. not the index of
+ * the byte just after the separator. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
+ int i;
+ int isVfsPath = 0;
+ const char *path;
+
/*
- * Call each of the "normalise path" functions in succession. This is a
- * special case, in which if we have a native filesystem handler, we call
- * it first. This is because the root of Tcl's filesystem is always a
- * native filesystem (i.e. '/' on unix is native).
+ * Pathnames starting with a UNC prefix and ending with a colon character
+ * are reserved for VFS use. These names can not conflict with real UNC
+ * pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
+ * rfc3986's definition of reg-name.
+ *
+ * We check these first to avoid useless calls to the native filesystem's
+ * normalizePathProc.
*/
+ path = Tcl_GetStringFromObj(pathPtr, &i);
+
+ if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/')
+ || (path[0] == '\\' && path[1] == '\\') ) ) {
+ for ( i = 2; ; i++) {
+ if (path[i] == '\0') break;
+ if (path[i] == path[0]) break;
+ }
+ --i;
+ if (path[i] == ':') isVfsPath = 1;
+ }
+ /*
+ * Call the the normalizePathProc routine of each registered filesystem.
+ */
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
- for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- continue;
- }
+
+ if (!isVfsPath) {
/*
- * TODO: Assume that we always find the native file system; it should
- * always be there...
+ * Find and call the native filesystem handler first if there is one
+ * because the root of Tcl's filesystem is always a native filesystem
+ * (i.e., '/' on unix is native).
*/
- if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
- startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
- startAt);
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
+ continue;
+ }
+
+ /*
+ * TODO: Always call the normalizePathProc here because it should
+ * always exist.
+ */
+
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
+ }
+ break;
}
- break;
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- /*
- * Skip the native system next time through.
- */
-
if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
+ /*
+ * Skip the native system this time through.
+ */
continue;
}
@@ -1439,7 +1397,7 @@ TclFSNormalizeToUniquePath(
}
/*
- * We could add an efficiency check like this:
+ * This efficiency check could be added:
* if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
@@ -1454,26 +1412,27 @@ TclFSNormalizeToUniquePath(
*
* TclGetOpenMode --
*
- * This routine is an obsolete, limited version of TclGetOpenModeEx()
- * below. It exists only to satisfy any extensions imprudently using it
- * via Tcl's internal stubs table.
+ * Obsolete. A limited version of TclGetOpenModeEx() which exists only to
+ * satisfy any extensions imprudently using it via Tcl's internal stubs
+ * table.
*
* Results:
- * Same as TclGetOpenModeEx().
+ * See TclGetOpenModeEx().
*
* Side effects:
- * Same as TclGetOpenModeEx().
+ * See TclGetOpenModeEx().
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(
- Tcl_Interp *interp, /* Interpreter to use for error reporting -
- * may be NULL. */
- const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
- int *seekFlagPtr) /* Set this to 1 if the caller should seek to
- * EOF during the opening of the file. */
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. May
+ * be NULL. */
+ const char *modeString, /* e.g. "r+" or "RDONLY CREAT". */
+ int *seekFlagPtr) /* Sets this to 1 to tell the caller to seek to
+ EOF after opening the file, and
+ * 0 otherwise. */
{
int binary = 0;
return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
@@ -1484,46 +1443,44 @@ TclGetOpenMode(
*
* TclGetOpenModeEx --
*
- * Computes a POSIX mode mask for opening a file, from a given string,
- * and also sets flags to indicate whether the caller should seek to EOF
- * after opening the file, and whether the caller should configure the
- * channel for binary data.
+ * Computes a POSIX mode mask for opening a file.
*
* Results:
- * On success, returns mode to pass to "open". If an error occurs, the
- * return value is -1 and if interp is not NULL, sets interp's result
- * object to an error message.
+ * The mode to pass to "open", or -1 if an error occurs.
*
* Side effects:
- * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to
- * seek to EOF after opening the file, or to 0 otherwise. Sets the
- * integer referenced by binaryPtr to 1 to tell the caller to seek to
- * configure the channel for binary data, or to 0 otherwise.
+ * Sets *seekFlagPtr to 1 to tell the caller to
+ * seek to EOF after opening the file, or to 0 otherwise.
+ *
+ * Sets *binaryPtr to 1 to tell the caller to configure the channel as a
+ * binary channel, or to 0 otherwise.
+ *
+ * If there is an error and interp is not NULL, sets interpreter result to
+ * an error message.
*
* Special note:
- * This code is based on a prototype implementation contributed by Mark
- * Diekhans.
+ * Based on a prototype implementation contributed by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenModeEx(
- Tcl_Interp *interp, /* Interpreter to use for error reporting -
- * may be NULL. */
+ Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for
+ * error reporting. */
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
- int *seekFlagPtr, /* Set this to 1 if the caller should seek to
- * EOF during the opening of the file. */
- int *binaryPtr) /* Set this to 1 if the caller should
- * configure the opened channel for binary
- * operations. */
+ int *seekFlagPtr, /* Sets this to 1 to tell the the caller to seek to
+ * EOF after opening the file, and 0 otherwise. */
+ int *binaryPtr) /* Sets this to 1 to tell the caller to
+ * configure the channel for binary
+ * operations after opening the file. */
{
int mode, modeArgc, c, i, gotRW;
const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
- * Check for the simpler fopen-like access modes (e.g. "r"). They are
+ * Check for the simpler fopen-like access modes like "r" which are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
*/
@@ -1533,8 +1490,7 @@ TclGetOpenModeEx(
mode = 0;
/*
- * Guard against international characters before using byte oriented
- * routines.
+ * Guard against wide characters before using byte-oriented routines.
*/
if (!(modeString[0] & 0x80)
@@ -1548,7 +1504,7 @@ TclGetOpenModeEx(
break;
case 'a':
/*
- * Added O_APPEND for proper automatic seek-to-end-on-write by the
+ * Add O_APPEND for proper automatic seek-to-end-on-write by the
* OS. [Bug 680143]
*/
@@ -1566,8 +1522,8 @@ TclGetOpenModeEx(
switch (modeString[i++]) {
case '+':
/*
- * Must remove the O_APPEND flag so that the seek command
- * works. [Bug 1773127]
+ * Remove O_APPEND so that the seek command works. [Bug
+ * 1773127]
*/
mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
@@ -1596,11 +1552,9 @@ TclGetOpenModeEx(
}
/*
- * The access modes are specified using a list of POSIX modes such as
- * O_CREAT.
+ * The access modes are specified as a list of POSIX modes like O_CREAT.
*
- * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL
- * interpreter is passed in.
+ * Tcl_SplitList must work correctly when interp is NULL.
*/
if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
@@ -1695,8 +1649,10 @@ TclGetOpenModeEx(
*
* Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
- * Read in a file and process the entire file as one gigantic Tcl
- * command. Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
+ * Reads a file and evaluates it as a script.
+ *
+ * Tcl_FSEvalFile is Tcl_FSEvalFileEx without the encoding argument.
+ *
* TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
@@ -1704,29 +1660,31 @@ TclGetOpenModeEx(
* file or an error indicating why the file couldn't be read.
*
* Side effects:
- * Depends on the commands in the file. During the evaluation of the
- * contents of the file, iPtr->scriptFile is made to point to pathPtr
- * (the old value is cached and replaced when this function returns).
+ * Arbitrary, depending on the contents of the script. While the script
+ * is evaluated iPtr->scriptFile is a reference to pathPtr, and after the
+ * evaluation completes, has its original value restored again.
*
*----------------------------------------------------------------------
*/
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. */
+ Tcl_Interp *interp, /* Interpreter that evaluates the script. */
+ Tcl_Obj *pathPtr) /* Pathname of file containing the script.
+ * Tilde-substitution is performed on this
+ * pathname. */
{
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
- * 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_Interp *interp, /* Interpreter that evaluates the script. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to process.
+ * Tilde-substitution is performed on this
+ * pathname. */
+ const char *encodingName) /* Either the name of an encoding or NULL to
+ use the utf-8 encoding. */
{
int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
@@ -1756,34 +1714,34 @@ Tcl_FSEvalFileEx(
}
/*
- * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
- * this cross-platform to allow for scripted documents. [Bug: 2040]
+ * The eof character is \32 (^Z). This is standard on Windows, and Tcl
+ * uses it on every 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 the encoding is specified, set the channel to that encoding.
+ * Otherwise use utf-8. If the encoding is unknown report an error.
*/
- if (encodingName != NULL) {
- if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
- != TCL_OK) {
- Tcl_Close(interp,chan);
- return result;
- }
+ if (encodingName == NULL) {
+ encodingName = "utf-8";
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp,chan);
+ return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
- * Try to read first character of stream, so we can check for utf-8 BOM to
- * be handled especially.
+ * Read first character of stream to check for utf-8 BOM
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1793,12 +1751,12 @@ Tcl_FSEvalFileEx(
string = Tcl_GetString(objPtr);
/*
- * If first character is not a BOM, append the remaining characters,
- * otherwise replace them. [Bug 3466099]
+ * If first character is not a BOM, append the remaining characters.
+ * Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xEF\xBB\xBF", 3)) < 0) {
+ memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1814,19 +1772,19 @@ Tcl_FSEvalFileEx(
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = TclGetStringFromObj(objPtr, &length);
/*
- * TIP #280 Force the evaluator to open a frame for a sourced file.
+ * TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
/*
- * 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'.
+ * Restore the original iPtr->scriptFile value, but because the value may
+ * have hanged during evaluation, don't assume it currently points to
+ * pathPtr.
*/
if (iPtr->scriptFile != NULL) {
@@ -1838,10 +1796,10 @@ Tcl_FSEvalFileEx(
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
- * Record information telling where the error occurred.
+ * Record information about where the error occurred.
*/
- const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ const char *pathString = TclGetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
@@ -1858,11 +1816,12 @@ Tcl_FSEvalFileEx(
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_Interp *interp, /* Interpreter in which to evaluate the script. */
+ Tcl_Obj *pathPtr, /* Pathname of a file containing the script to
+ * evaluate. Tilde-substitution is performed on
+ * this pathname. */
+ const char *encodingName) /* The name of an encoding to use, or NULL to
+ * use the utf-8 encoding. */
{
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile, *objPtr;
@@ -1888,36 +1847,37 @@ TclNREvalFile(
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
+ TclPkgFileSeen(interp, Tcl_GetString(pathPtr));
/*
- * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
- * this cross-platform to allow for scripted documents. [Bug: 2040]
+ * The eof character is \32 (^Z). This is standard on Windows, and Tcl
+ * uses it on every 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 the encoding is specified, set the channel to that encoding.
+ * Otherwise use utf-8. If the encoding is unknown report an error.
*/
- if (encodingName != NULL) {
- if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
- != TCL_OK) {
- Tcl_Close(interp,chan);
- return TCL_ERROR;
- }
+ if (encodingName == NULL) {
+ encodingName = "utf-8";
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp, chan);
+ return TCL_ERROR;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
- * Try to read first character of stream, so we can check for utf-8 BOM to
- * be handled especially.
+ * Read first character of stream to check for utf-8 BOM
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1928,12 +1888,12 @@ TclNREvalFile(
string = Tcl_GetString(objPtr);
/*
- * If first character is not a BOM, append the remaining characters,
- * otherwise replace them. [Bug 3466099]
+ * If first character is not a BOM, append the remaining characters.
+ * Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xEF\xBB\xBF", 3)) < 0) {
+ memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1953,7 +1913,7 @@ TclNREvalFile(
Tcl_IncrRefCount(iPtr->scriptFile);
/*
- * TIP #280: Force the evaluator to open a frame for a sourced file.
+ * TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
@@ -1969,14 +1929,14 @@ EvalFileCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *oldScriptFile = data[0];
- Tcl_Obj *pathPtr = data[1];
- Tcl_Obj *objPtr = data[2];
+ Tcl_Obj *oldScriptFile = (Tcl_Obj *)data[0];
+ Tcl_Obj *pathPtr = (Tcl_Obj *)data[1];
+ Tcl_Obj *objPtr = (Tcl_Obj *)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'.
+ * Restore the original iPtr->scriptFile value, but because the value may
+ * have hanged during evaluation, don't assume it currently points to
+ * pathPtr.
*/
if (iPtr->scriptFile != NULL) {
@@ -1988,11 +1948,11 @@ EvalFileCallback(
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
- * Record information telling where the error occurred.
+ * Record information about where the error occurred.
*/
int length;
- const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ const char *pathString = TclGetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
@@ -2011,16 +1971,15 @@ EvalFileCallback(
*
* Tcl_GetErrno --
*
- * Gets the current value of the Tcl error code variable. This is
- * currently the global variable "errno" but could in the future change
+ * Currently the global variable "errno", but could in the future change
* to something else.
*
* Results:
- * The value of the Tcl error code variable.
+ * The current Tcl error number.
*
* Side effects:
- * None. Note that the value of the Tcl error code variable is UNDEFINED
- * if a call to Tcl_SetErrno did not precede this call.
+ * None. The value of the Tcl error code variable is only defined if it
+ * was set by a previous call to Tcl_SetErrno.
*
*----------------------------------------------------------------------
*/
@@ -2029,8 +1988,8 @@ int
Tcl_GetErrno(void)
{
/*
- * On some platforms, errno is really a thread local (implemented by the C
- * library).
+ * On some platforms errno is thread-local, as implemented by the C
+ * library.
*/
return errno;
@@ -2041,15 +2000,15 @@ Tcl_GetErrno(void)
*
* Tcl_SetErrno --
*
- * 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!
+ * Sets the Tcl error code to the given value. On some saner platforms
+ * this is implemented in the C library as a thread-local value , but this
+ * is *really* unsafe to assume!
*
* Results:
* None.
*
* Side effects:
- * Modifies the value of the Tcl error code variable.
+ * Modifies the the Tcl error code value.
*
*----------------------------------------------------------------------
*/
@@ -2059,8 +2018,8 @@ Tcl_SetErrno(
int err) /* The new value. */
{
/*
- * On some platforms, errno is really a thread local (implemented by the C
- * library).
+ * On some platforms, errno is implemented by the C library as a thread
+ * local value
*/
errno = err;
@@ -2071,24 +2030,21 @@ Tcl_SetErrno(
*
* Tcl_PosixError --
*
- * This function is typically called after UNIX kernel calls return
- * errors. It stores machine-readable information about the error in
- * errorCode field of interp and returns an information string for the
- * caller's use.
+ * Typically called after a UNIX kernel call returns an error. Sets the
+ * interpreter errorCode to machine-parsable information about the error.
*
* Results:
- * The return value is a human-readable string describing the error.
+ * A human-readable sring describing the error.
*
* Side effects:
- * The errorCode field of the interp is set.
+ * Sets the errorCode value of the interpreter.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_PosixError(
- Tcl_Interp *interp) /* Interpreter whose errorCode field is to be
- * set. */
+ Tcl_Interp *interp) /* Interpreter to set the errorCode of */
{
const char *id, *msg;
@@ -2104,11 +2060,10 @@ Tcl_PosixError(
*----------------------------------------------------------------------
*
* Tcl_FSStat --
+ * Calls 'statProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of stat and lsat.
+ * Replaces the standard library routines stat.
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
*
* Results:
* See stat documentation.
@@ -2121,8 +2076,10 @@ Tcl_PosixError(
int
Tcl_FSStat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ * current CP). */
+ Tcl_StatBuf *buf) /* A buffer to hold the results of the call to
+ * stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2137,11 +2094,11 @@ Tcl_FSStat(
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
+ * Calls the 'lstatProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of lstat. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
- * If no 'lstat' function is listed, but a 'stat' function is, then Tcl
- * will fall back on the stat function.
+ * Replaces the library version of lstat. If the filesystem doesn't
+ * provide lstatProc but does provide statProc, Tcl falls back to
+ * statProc.
*
* Results:
* See lstat documentation.
@@ -2154,8 +2111,9 @@ Tcl_FSStat(
int
Tcl_FSLstat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of that call to stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2176,8 +2134,9 @@ Tcl_FSLstat(
*
* Tcl_FSAccess --
*
- * This function replaces the library version of access. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'accessProc' of the filesystem corresponding to pathPtr.
+ *
+ * Replaces the library version of access.
*
* Results:
* See access documentation.
@@ -2190,7 +2149,7 @@ Tcl_FSLstat(
int
Tcl_FSAccess(
- Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
+ Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */
int mode) /* Permission setting. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2207,38 +2166,36 @@ Tcl_FSAccess(
*
* Tcl_FSOpenFileChannel --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'openfileChannelProc' of the filesystem corresponding to
+ * pathPtr.
*
* Results:
- * The new channel or NULL, if the named file could not be opened.
+ * The new channel, or NULL if the named file could not be opened.
*
* Side effects:
- * May open the channel and may cause creation of a file on the file
- * system.
+ * Opens a channel, possibly creating the corresponding the file on the
+ * filesystem.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_FSOpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- Tcl_Obj *pathPtr, /* Name of file to open. */
+ Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
+ Tcl_Obj *pathPtr, /* Pathname 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? */
+ int permissions) /* What modes to use if opening the file
+ involves creating it. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
- /*
- * We need this just to ensure we return the correct error messages under
- * some circumstances.
- */
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
+ /*
+ * Return the correct error message.
+ */
return NULL;
}
@@ -2247,8 +2204,8 @@ Tcl_FSOpenFileChannel(
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 to determine whether to seek at the outset
+ * and/or set the channel into binary mode.
*/
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
@@ -2257,7 +2214,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Do the actual open() call.
+ * Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
@@ -2267,7 +2224,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Apply appropriate flags parsed out above.
+ * Seek and/or set binary mode as determined above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
@@ -2304,8 +2261,10 @@ Tcl_FSOpenFileChannel(
*
* Tcl_FSUtime --
*
- * This function replaces the library version of utime. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'uTimeProc' of the filesystem corresponding to the given
+ * pathname.
+ *
+ * Replaces the library version of utime.
*
* Results:
* See utime documentation.
@@ -2318,9 +2277,8 @@ Tcl_FSOpenFileChannel(
int
Tcl_FSUtime(
- Tcl_Obj *pathPtr, /* File to change access/modification
- * times. */
- struct utimbuf *tval) /* Structure containing access/modification
+ Tcl_Obj *pathPtr, /* Pathaname of file to call uTimeProc on */
+ struct utimbuf *tval) /* Specifies the access/modification
* times to use. Should not be modified. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2337,11 +2295,10 @@ Tcl_FSUtime(
*
* NativeFileAttrStrings --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for listing the set of possible
- * attribute strings. This function is part of Tcl's native filesystem
- * support, and is placed here because it is shared by Unix and Windows
- * code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem, for listing the set of possible attribute strings.
+ * Part of Tcl's native filesystem support. Placed here because it is used
+ * under both Unix and Windows.
*
* Results:
* An array of strings
@@ -2354,8 +2311,8 @@ Tcl_FSUtime(
static const char *const *
NativeFileAttrStrings(
- Tcl_Obj *pathPtr,
- Tcl_Obj **objPtrRef)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj **))
{
return tclpFileAttrStrings;
}
@@ -2365,16 +2322,18 @@ NativeFileAttrStrings(
*
* NativeFileAttrsGet --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for 'get' operations. This
- * function is part of Tcl's native filesystem support, and is placed
- * here because it is shared by Unix and Windows code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem for 'get' operations. Part of Tcl's native
+ * filesystem support. Defined here because it is used under both Unix
+ * and Windows.
*
* Results:
- * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
- * was returned) is likely to have a refCount of zero. Either way we must
- * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
- * refCount to ensure it is properly freed.
+ * Standard Tcl return code.
+ *
+ * If there was no error, stores in objPtrRef a pointer to a new object
+ * having a refCount of zero and holding the result. The caller should
+ * store it somewhere, e.g. as the Tcl result, or decrement its refCount
+ * to free it.
*
* Side effects:
* None.
@@ -2386,8 +2345,8 @@ static int
NativeFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* path of file we are operating on. */
- Tcl_Obj **objPtrRef) /* for output. */
+ Tcl_Obj *pathPtr, /* Pathname of the file */
+ Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */
{
return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef);
}
@@ -2397,13 +2356,13 @@ NativeFileAttrsGet(
*
* NativeFileAttrsSet --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for 'set' operations. This
- * function is part of Tcl's native filesystem support, and is placed
- * here because it is shared by Unix and Windows code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem for 'set' operations. A part of Tcl's native
+ * filesystem support, it is defined here because it is used under both
+ * Unix and Windows.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
* None.
@@ -2415,8 +2374,8 @@ static int
NativeFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* path of file we are operating on. */
- Tcl_Obj *objPtr) /* set to this value. */
+ Tcl_Obj *pathPtr, /* Pathname of the file */
+ Tcl_Obj *objPtr) /* The value to set. */
{
return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr);
}
@@ -2426,18 +2385,16 @@ NativeFileAttrsSet(
*
* Tcl_FSFileAttrStrings --
*
- * This function implements part of the hookable 'file attributes'
- * subcommand. The appropriate function for the filesystem to which
- * pathPtr belongs will be called.
+ * Implements part of the hookable 'file attributes'
+ * subcommand.
+ *
+ * Calls 'fileAttrStringsProc' of the filesystem corresponding to the
+ * given pathname.
*
* Results:
- * The called function may either return an array of strings, or may
- * instead return NULL and place a Tcl list into the given objPtrRef.
- * Tcl will take that list and first increment its refCount before using
- * it. On completion of that use, Tcl will decrement its refCount. Hence
- * if the list should be disposed of by Tcl when done, it should have a
- * refCount of zero, and if the list should not be disposed of, the
- * filesystem should ensure it retains a refCount on the object.
+ * Returns an array of strings, or returns NULL and stores in objPtrRef
+ * a pointer to a new Tcl list having a refCount of zero, and containing
+ * the file attribute strings.
*
* Side effects:
* None.
@@ -2464,11 +2421,13 @@ Tcl_FSFileAttrStrings(
*
* TclFSFileAttrIndex --
*
- * Helper function for converting an attribute name to an index into the
+ * Given an attribute name, determines the index of the attribute in the
* attribute table.
*
* Results:
- * Tcl result code, index written to *indexPtr on result==TCL_OK
+ * A standard Tcl result code.
+ *
+ * If there is no error, stores the index in *indexPtr.
*
* Side effects:
* None.
@@ -2478,10 +2437,9 @@ Tcl_FSFileAttrStrings(
int
TclFSFileAttrIndex(
- Tcl_Obj *pathPtr, /* File whose attributes are to be indexed
- * into. */
- const char *attributeName, /* The attribute being looked for. */
- int *indexPtr) /* Where to write the found index. */
+ Tcl_Obj *pathPtr, /* Pathname of the file. */
+ const char *attributeName, /* The name of the attribute. */
+ int *indexPtr) /* A place to store the result. */
{
Tcl_Obj *listObj = NULL;
const char *const *attrTable;
@@ -2518,7 +2476,7 @@ TclFSFileAttrIndex(
int i, objc;
Tcl_Obj **objv;
- if (TclListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) {
TclDecrRefCount(listObj);
return TCL_ERROR;
}
@@ -2541,15 +2499,16 @@ TclFSFileAttrIndex(
*
* Tcl_FSFileAttrsGet --
*
- * This function implements read access for the hookable 'file
- * attributes' subcommand. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Implements read access for the hookable 'file attributes' subcommand.
+ *
+ * Calls 'fileAttrsGetProc' of the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
- * was returned) is likely to have a refCount of zero. Either way we must
- * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
- * refCount to ensure it is properly freed.
+ * A standard Tcl return code.
+ *
+ * On success, stores in objPtrRef a pointer to a new Tcl_Obj having a
+ * refCount of zero, and containing the result.
*
* Side effects:
* None.
@@ -2560,9 +2519,9 @@ TclFSFileAttrIndex(
int
Tcl_FSFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
- int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* filename we are operating on. */
- Tcl_Obj **objPtrRef) /* for output. */
+ int index, /* The index of the attribute command. */
+ Tcl_Obj *pathPtr, /* The pathname of the file. */
+ Tcl_Obj **objPtrRef) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2578,12 +2537,14 @@ Tcl_FSFileAttrsGet(
*
* Tcl_FSFileAttrsSet --
*
- * This function implements write access for the hookable 'file
- * attributes' subcommand. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Implements write access for the hookable 'file
+ * attributes' subcommand.
+ *
+ * Calls 'fileAttrsSetProc' for the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
* None.
@@ -2594,9 +2555,9 @@ Tcl_FSFileAttrsGet(
int
Tcl_FSFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
- int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* filename we are operating on. */
- Tcl_Obj *objPtr) /* Input value. */
+ int index, /* The index of the attribute command. */
+ Tcl_Obj *pathPtr, /* The pathname of the file. */
+ Tcl_Obj *objPtr) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2612,33 +2573,25 @@ Tcl_FSFileAttrsSet(
*
* Tcl_FSGetCwd --
*
- * This function replaces the library version of getcwd().
- *
- * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own
- * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this
- * with the cwd's containing filesystem, if that filesystem provides a
- * cwdProc (e.g. the native filesystem).
+ * Replaces the library version of getcwd().
*
- * Note that if Tcl's cwd is not in the native filesystem, then of course
- * Tcl's cwd and the native cwd are different: extensions should
- * therefore ensure they only access the cwd through this function to
- * avoid confusion.
+ * Most virtual filesystems do not implement cwdProc. Tcl maintains its
+ * own record of the current directory which it keeps synchronized with
+ * the filesystem corresponding to the pathname of the current directory
+ * if the filesystem provides a cwdProc (the native filesystem does).
*
- * If a global cwdPathPtr already exists, it is cached in the thread's
- * private data structures and reference to the cached copy is returned,
- * subject to a synchronisation attempt in that cwdPathPtr's fs.
- *
- * Otherwise, the chain of functions that have been "inserted" into the
- * filesystem will be called in succession until either a value other
- * than NULL is returned, or the entire list is visited.
+ * If Tcl's current directory is not in the native filesystem, Tcl's
+ * current directory and the current directory of the process are
+ * different. To avoid confusion, extensions should call Tcl_FSGetCwd to
+ * obtain the current directory from Tcl rather than from the operating
+ * system.
*
* Results:
- * The result is a pointer to a Tcl_Obj specifying the current directory,
- * or NULL if the current directory could not be determined. If NULL is
- * returned, an error message is left in the interp's result.
+ * Returns a pointer to a Tcl_Obj having a refCount of 1 and containing
+ * the current thread's local copy of the global cwdPathPtr value.
*
- * The result already has its refCount incremented for the caller. When
- * it is no longer needed, that refCount should be decremented.
+ * Returns NULL if the current directory could not be determined, and
+ * leaves an error message in the interpreter's result.
*
* Side effects:
* Various objects may be freed and allocated.
@@ -2657,9 +2610,10 @@ Tcl_FSGetCwd(
Tcl_Obj *retVal = NULL;
/*
- * We've never been called before, try to find a cwd. Call each of the
- * "Tcl_GetCwd" function in succession. A non-NULL return value
- * indicates the particular function has succeeded.
+ * This is the first time this routine has been called. Call
+ * 'getCwdProc' for each registered filsystems until one returns
+ * something other than NULL, which is a pointer to the pathname of the
+ * current directory.
*/
fsRecPtr = FsGetFirstFilesystem();
@@ -2668,6 +2622,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -2683,7 +2638,7 @@ Tcl_FSGetCwd(
Tcl_Obj *norm;
/*
- * Looks like a new current directory.
+ * Found the pathname of the current directory.
*/
retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
@@ -2691,15 +2646,16 @@ Tcl_FSGetCwd(
norm = TclFSNormalizeAbsolutePath(interp,retVal);
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.
+ * Assign to global storage the pathname of the current
+ * directory and copy it into thread-local storage as
+ * well.
*
- * 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.
+ * At system startup multiple threads could in principle
+ * call this function simultaneously, which is a little
+ * peculiar, but should be fine given the mutex locks in
+ * FSUPdateCWD. Once some value is assigned to the global
+ * variable the 'else' branch below is always taken, which
+ * is simpler.
*/
FsUpdateCwd(norm, retCd);
@@ -2719,44 +2675,48 @@ Tcl_FSGetCwd(
}
Disclaim();
- /*
- * Now the 'cwd' may NOT be normalized, at least on some platforms.
- * For the sake of efficiency, we want a completely normalized cwd at
- * all times.
- *
- * Finally, if retVal is NULL, we do not have a cwd, which could be
- * problematic.
- */
-
if (retVal != NULL) {
+ /*
+ * On some platforms the pathname of the current directory might
+ * not be normalized. For efficiency, ensure that it is
+ * normalized. For the sake of efficiency, we want a completely
+ * normalized current working directory at all times.
+ */
+
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
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.
+ * We found a current working directory, 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.
+ * Threading issue: Multiple threads at system startup could in
+ * principle call this function simultaneously. They will
+ * therefore each set the cwdPathPtr independently, which 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.
*/
- ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
+ void *cd = (void *) Tcl_FSGetNativePath(norm);
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
+ } else {
+ /*
+ * retVal is NULL. There is no current directory, which could be
+ * problematic.
+ */
}
} else {
/*
- * We already have a cwd cached, but we want to give the filesystem it
- * is in a chance to check whether that cwd has changed, or is perhaps
- * no longer accessible. This allows an error to be thrown if, say,
- * the permissions on that directory have changed.
+ * There is a thread-local value for the pathname of the current
+ * directory. Give corresponding filesystem a chance update the value
+ * if it is out-of-date. This allows an error to be thrown if, for
+ * example, the permissions on the current working directory have
+ * changed.
*/
const Tcl_Filesystem *fsPtr =
@@ -2764,16 +2724,11 @@ Tcl_FSGetCwd(
ClientData retCd = NULL;
Tcl_Obj *retVal, *norm;
- /*
- * If the filesystem couldn't be found, or if no cwd function exists
- * for this filesystem, then we simply assume the cached cwd is ok.
- * If we do call a cwd, we must watch for errors (if the cwd returns
- * NULL). This ensures that, say, on Unix if the permissions of the
- * cwd change, 'pwd' does actually throw the correct error in Tcl.
- * (This is tested for in the test suite on unix).
- */
-
if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
+ /*
+ * There is no corresponding filesystem or the filesystem does not
+ * have a getCwd routine. Just assume current local value is ok.
+ */
goto cdDidNotChange;
}
@@ -2805,28 +2760,25 @@ Tcl_FSGetCwd(
Tcl_IncrRefCount(retVal);
}
- /*
- * Check if the 'cwd' function returned an error; if so, reset the
- * cwd.
- */
-
if (retVal == NULL) {
+ /*
+ * The current directory could not not determined. Reset the
+ * current direcory to ensure, for example, that 'pwd' does actually
+ * throw the correct error in Tcl. This is tested for in the test
+ * suite on unix.
+ */
+
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
}
- /*
- * Normalize the path.
- */
-
norm = TclFSNormalizeAbsolutePath(interp, retVal);
- /*
- * 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) {
+ /*
+ * 'norm' shouldn't ever be NULL, but we are careful.
+ */
+
/* Do nothing */
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
@@ -2834,32 +2786,35 @@ Tcl_FSGetCwd(
} 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.
+ /*
+ * Determine whether the filesystem's answer is the same as the
+ * cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr'
+ * are normalized pathnames, do something 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;
- str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = Tcl_GetStringFromObj(norm, &len2);
+ str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = TclGetStringFromObj(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.
+ * The pathname values are equal so retain the old pathname
+ * object which is probably already shared and free the
+ * normalized pathname that was just produced.
*/
-
cdEqual:
Tcl_DecrRefCount(norm);
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
}
} else {
+ /*
+ * The pathname of the current directory is not the same as
+ * this thread's local cached value. Replace the local value.
+ */
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
}
@@ -2880,17 +2835,19 @@ Tcl_FSGetCwd(
*
* Tcl_FSChdir --
*
- * This function replaces the library version of chdir().
+ * Replaces the library version of chdir().
*
- * The path is normalized and then passed to the filesystem which claims
- * it.
+ * Calls 'chdirProc' of the filesystem that corresponds to the given
+ * pathname.
*
* Results:
- * See chdir() documentation. If successful, we keep a record of the
- * successful path in cwdPathPtr for subsequent calls to getcwd.
+ * See chdir() documentation.
*
* Side effects:
- * See chdir() documentation. The global cwdPathPtr may change value.
+ * See chdir() documentation.
+ *
+ * On success stores in cwdPathPtr the pathname of the new current
+ * directory.
*
*----------------------------------------------------------------------
*/
@@ -2915,70 +2872,46 @@ Tcl_FSChdir(
if (fsPtr != NULL) {
if (fsPtr->chdirProc != NULL) {
/*
- * If this fails, an appropriate errno will have been stored using
- * 'Tcl_SetErrno()'.
+ * If this fails Tcl_SetErrno() has already been called.
*/
retVal = fsPtr->chdirProc(pathPtr);
} else {
/*
- * Fallback on stat-based implementation.
+ * Fallback to stat-based implementation.
*/
Tcl_StatBuf buf;
- /*
- * 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.
- */
-
if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
&& (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
/*
- * We allow the chdir.
+ * stat was successful, and the file is a directory and is
+ * readable. Can proceed to change the current directory.
*/
retVal = 0;
+ } else {
+ /*
+ * 'Tcl_SetErrno()' has already been called.
+ */
}
}
} else {
Tcl_SetErrno(ENOENT);
}
- /*
- * The cwd changed, or an error was thrown. If an error was thrown, we can
- * just continue (and that will report the error to the user). If there
- * 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
- * though. The private authoritative representation of the current working
- * directory stored in cwdPathPtr in static memory will be out-of-sync
- * with the real OS-maintained value. The first call to Tcl_FSGetCwd will
- * however recalculate the private copy to match the OS-value so
- * everything will work right.
- *
- * However, if there is no getCwdProc, then we _must_ update our private
- * storage of the cwd, since this is the only opportunity to do that!
- *
- * Note: We currently call this block of code irrespective of whether
- * there was a getCwdProc or not, but the code should all in principle
- * work if we only call this block if fsPtr->getCwdProc == NULL.
- */
-
if (retVal == 0) {
+
+ /* Assume that the cwd was actually changed to the normalized value
+ * just calculated, and cache that information. */
+
/*
- * Note that this normalized path may be different to what we found
- * above (or at least a different object), if the filesystem epoch
- * changed recently. This can actually happen with scripted documents
- * very easily. Therefore we ask for the normalized path again (the
- * correct value will have been cached as a result of the
- * Tcl_FSGetFileSystemForPath call above anyway).
+ * If the filesystem epoch changed recently, the normalized pathname or
+ * its internal handle may be different from what was found above.
+ * This can easily be the case with scripted documents . Therefore get
+ * the normalized pathname again. The correct value will have been
+ * cached as a result of the Tcl_FSGetFileSystemForPath call, above.
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
@@ -2990,45 +2923,60 @@ Tcl_FSChdir(
}
if (fsPtr == &tclNativeFilesystem) {
- /*
- * For the native filesystem, we keep a cache of the native
- * representation of the cwd. But, we want to do that for the
- * exact format that is returned by 'getcwd' (so that we can later
- * compare the two representations for equality), which might not
- * be exactly the same char-string as the native representation of
- * the fully normalized path (e.g. on Windows there's a
- * forward-slash vs backslash difference). Hence we ask for this
- * again here. On Unix it might actually be true that we always
- * have the correct form in the native rep in which case we could
- * simply use:
- * cd = Tcl_FSGetNativePath(pathPtr);
- * instead. This should be examined by someone on Unix.
- */
-
ClientData cd;
ClientData oldcd = tsdPtr->cwdClientData;
/*
- * Assumption we are using a filesystem version 2.
+ * Assume that the native filesystem has a getCwdProc and that it
+ * is at version 2.
*/
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
cd = proc2(oldcd);
if (cd != oldcd) {
+ /*
+ * Call getCwdProc() and store the resulting internal handle to
+ * compare things with it later. This might might not be
+ * exactly the same string as that of the fully normalized
+ * pathname. For example, for the Windows internal handle the
+ * separator is the backslash character. On Unix it might well
+ * be true that the internal handle is the fully normalized
+ * pathname and one could simply use:
+ * cd = Tcl_FSGetNativePath(pathPtr);
+ * but this can't be guaranteed in the general case. In fact,
+ * the internal handle could be any value the filesystem
+ * decides to use to identify a node.
+ */
+
FsUpdateCwd(normDirName, cd);
}
} else {
+ /*
+ * Tcl_FSGetCwd() synchronizes the file-global cwdPathPtr if
+ * needed. However, if there is no 'getCwdProc', cwdPathPtr must be
+ * updated right now because there won't be another chance. This
+ * block of code is currently executed whether or not the
+ * filesystem provides a getCwdProc, but it should in principle
+ * work to only call this block if fsPtr->getCwdProc == NULL.
+ */
+
FsUpdateCwd(normDirName, NULL);
}
- /*
- * If the filesystem changed between old and new cwd
- * force filesystem refresh on path objects.
- */
if (oldFsPtr != NULL && fsPtr != oldFsPtr) {
+ /*
+ * The filesystem of the current directory is not the same as the
+ * filesystem of the previous current directory. Invalidate All
+ * FsPath objects.
+ */
Tcl_FSMountsChanged(NULL);
}
+ } else {
+ /*
+ * The current directory is now changed or an error occurred and an
+ * error message is now set. Just continue.
+ */
}
return retVal;
@@ -3039,25 +2987,17 @@ Tcl_FSChdir(
*
* Tcl_FSLoadFile --
*
- * Dynamically loads a binary code file into memory and returns the
- * addresses of two functions within that file, if they are defined. The
- * appropriate function for the filesystem to which pathPtr belongs will
- * be called.
- *
- * Note that the native filesystem doesn't actually assume 'pathPtr' is a
- * path. Rather it assumes pathPtr is either a path or just the name
- * (tail) of a file which can be found somewhere in the environment's
- * loadable path. This behaviour is not very compatible with virtual
- * filesystems (and has other problems documented in the load man-page),
- * so it is advised that full paths are always used.
+ * Loads a dynamic shared object by passing the given pathname unmodified
+ * to Tcl_LoadFile, and provides pointers to the functions named by 'sym1'
+ * and 'sym2', and another pointer to a function that unloads the object.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error message
- * is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, sets the
+ * interpreter's result to an error message.
*
* Side effects:
- * New code suddenly appears in memory. This may later be unloaded by
- * passing the clientData to the unloadProc.
+ * A dynamic shared object is loaded into memory. This may later be
+ * unloaded by passing the handlePtr to *unloadProcPtr.
*
*----------------------------------------------------------------------
*/
@@ -3065,42 +3005,31 @@ Tcl_FSChdir(
int
Tcl_FSLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Obj *pathPtr, /* Name of the file containing the desired
- * code. */
+ Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic shared object.
+ */
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,
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded
- * file which will be passed back to
+ /* Names of two functions to find in the
+ * dynamic shared object. */
+ Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr,
+ /* Places to store pointers to the functions
+ * named by sym1 and sym2. */
+ Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded
+ * object. Can be passed to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr)
- /* Filled with address of Tcl_FSUnloadFileProc
- * function which should be used for this
- * file. */
+ TCL_UNUSED(Tcl_FSUnloadFileProc **))
{
const char *symbols[3];
void *procPtrs[2];
int res;
- /*
- * Initialize the arrays.
- */
-
symbols[0] = sym1;
symbols[1] = sym2;
symbols[2] = NULL;
- /*
- * Perform the load.
- */
-
res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr);
if (res == TCL_OK) {
- *proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0];
- *proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1];
+ *proc1Ptr = (Tcl_LibraryInitProc *) procPtrs[0];
+ *proc2Ptr = (Tcl_LibraryInitProc *) procPtrs[1];
} else {
*proc1Ptr = *proc2Ptr = NULL;
}
@@ -3113,49 +3042,40 @@ Tcl_FSLoadFile(
*
* 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
- * defined. The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * Load a dynamic shared object by calling 'loadFileProc' of the
+ * filesystem corresponding to the given pathname, and then finds within
+ * the loaded object the functions named in symbols[].
*
- * Note that the native filesystem doesn't actually assume 'pathPtr' is a
- * path. Rather it assumes pathPtr is either a path or just the name
- * (tail) of a file which can be found somewhere in the environment's
- * loadable path. This behaviour is not very compatible with virtual
- * filesystems (and has other problems documented in the load man-page),
- * so it is advised that full paths are always used.
+ * The given pathname is passed unmodified to `loadFileProc`, which
+ * decides how to resolve it. On POSIX systems the native filesystem
+ * passes the given pathname to dlopen(), which resolves the filename
+ * according to its own set of rules. This behaviour is not very
+ * compatible with virtual filesystems, and has other problems as
+ * documented for [load], so it is recommended to use an absolute
+ * pathname.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error message
- * is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, sets the
+ * interpreter result to an error message.
*
* Side effects:
- * New code suddenly appears in memory. This may later be unloaded by
- * calling TclFS_UnloadFile.
+ * Memory is allocated for the new object. May be freed by calling
+ * TclFS_UnloadFile.
*
*----------------------------------------------------------------------
*/
/*
- * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY
- * error) yet somehow trash some internal data structures which prevents the
- * second and further shared libraries from getting properly loaded. Only the
- * first is ok. We try to get around the issue by not unlinking,
- * i.e. emulating the behaviour of the older HPUX which denied removal.
+ * Modern HPUX allows the unlink (no ETXTBSY error) yet somehow trashes some
+ * internal data structures, preventing any additional dynamic shared objects
+ * from getting properly loaded. Only the first is ok. Work around the issue
+ * by not unlinking, i.e., emulating the behaviour of the older HPUX which
+ * denied removal.
*
* Doing the unlink is also an issue within docker containers, whose AUFS
* bungles this as well, see
* https://github.com/dotcloud/docker/issues/1911
*
- * For these situations the change below makes the execution of the unlink
- * semi-controllable at runtime.
- *
- * An AUFS filesystem (if it can be detected) will force avoidance of
- * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a
- * users general request (unlink and not.
- *
- * By default the unlink is done (if not in AUFS). However if the variable is
- * present and set to true (any integer > 0) then the unlink is skipped.
*/
#ifdef _WIN32
@@ -3166,55 +3086,66 @@ Tcl_FSLoadFile(
#endif
static int
-skipUnlink (Tcl_Obj* shlibFile)
+skipUnlink(
+ Tcl_Obj *shlibFile)
{
- /* Order of testing:
- * 1. On hpux we generally want to skip unlink in general
+ /*
+ * Unlinking is not performed in the following cases:
*
- * Outside of hpux then:
- * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int)
- * 3. For general AUFS environment (statfs, if available).
+ * 1. The operating system is HPUX.
*
- * Ad 2: This variable can disable/override the AUFS detection, i.e. for
- * testing if a newer AUFS does not have the bug any more.
+ * 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
+ * set to true (an integer > 0)
+ *
+ * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available).
*
- * Ad 3: This is conditionally compiled in. Condition currently must be set manually.
- * This part needs proper tests in the configure(.in).
*/
+
#ifdef hpux
+ (void)shlibFile;
return 1;
#else
- WCHAR *skipstr;
+ WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
- skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
-#ifdef TCL_TEMPLOAD_NO_UNLINK
+#ifndef TCL_TEMPLOAD_NO_UNLINK
+ (void)shlibFile;
+#else
+/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether
+ * this automatic overriding of unlink is included.
+ */
#ifndef NO_FSTATFS
{
struct statfs fs;
- /* Have fstatfs. May not have the AUFS super magic ... Indeed our build
+ /*
+ * Have fstatfs. May not have the AUFS super magic ... Indeed our build
* box is too old to have it directly in the headers. Define taken from
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
- * Better reference will be gladly taken.
+ * Better reference will be gladly accepted.
*/
#ifndef AUFS_SUPER_MAGIC
+/* AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for
+ * testing if a newer AUFS does not have the bug any more.
+*/
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
- if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) &&
- (fs.f_type == AUFS_SUPER_MAGIC)) {
+ if ((statfs(Tcl_GetString(shlibFile), &fs) == 0)
+ && (fs.f_type == AUFS_SUPER_MAGIC)) {
return 1;
}
}
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
- /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
- * Don't skip */
+ /*
+ * No HPUX, environment variable override, or AUFS detected. Perform
+ * unlink.
+ */
return 0;
#endif /* hpux */
}
@@ -3222,16 +3153,15 @@ skipUnlink (Tcl_Obj* shlibFile)
int
Tcl_LoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Obj *pathPtr, /* Name of the file containing the desired
- * code. */
- const char *const symbols[],/* Names of functions to look up in the file's
- * symbol table. */
+ Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic
+ * shared object. */
+ const char *const symbols[],/* A null-terminated array of names of
+ * functions to find in the loaded object. */
int flags, /* Flags */
- void *procVPtrs, /* Where to return the addresses corresponding
- * to symbols[]. */
- Tcl_LoadHandle *handlePtr) /* Filled with token for shared library
- * information which can be used in
- * TclpFindSymbol. */
+ void *procVPtrs, /* A place to store pointers to the functions
+ * named by symbols[]. */
+ Tcl_LoadHandle *handlePtr) /* A place to hold a token for the loaded object.
+ * Can be used by TclpFindSymbol. */
{
void **procPtrs = (void **) procVPtrs;
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -3269,10 +3199,11 @@ Tcl_LoadFile(
}
/*
- * The filesystem doesn't support 'load', so we fall back on the following
- * technique:
- *
- * First check if it is readable -- and exists!
+ * The filesystem doesn't support 'load'. Fall to the following:
+ */
+
+ /*
+ * Make sure the file is accessible.
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
@@ -3286,9 +3217,9 @@ Tcl_LoadFile(
#ifdef TCL_LOAD_FROM_MEMORY
/*
- * The platform supports loading code from memory, so ask for a buffer of
- * the appropriate size, read the file into it and load the code from the
- * buffer:
+ * The platform supports loading a dynamic shared object from memory.
+ * Create a sufficiently large buffer, read the file into it, and then load
+ * the dynamic shared object from the buffer:
*/
{
@@ -3304,7 +3235,7 @@ Tcl_LoadFile(
size = (int) statBuf.st_size;
/*
- * Tcl_Read takes an int: check that file size isn't wide.
+ * Tcl_Read takes an int: Determine whether the file size is wide.
*/
if (size != (Tcl_WideInt) statBuf.st_size) {
@@ -3319,7 +3250,7 @@ Tcl_LoadFile(
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
- ret = Tcl_Read(data, buffer, size);
+ ret = Tcl_Read(data, (char *)buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
&unloadProcPtr, flags);
@@ -3335,8 +3266,7 @@ Tcl_LoadFile(
#endif /* TCL_LOAD_FROM_MEMORY */
/*
- * Get a temporary filename to use, first to copy the file into, and then
- * to load.
+ * Get a temporary filename, first to copy the file into, and then to load.
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
@@ -3348,11 +3278,15 @@ Tcl_LoadFile(
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
/*
- * We already know we can't use Tcl_FSLoadFile from this filesystem,
- * and we must avoid a possible infinite loop. Try to delete the file
- * we probably created, and then exit.
+ * Tcl_FSLoadFile isn't available for the filesystem of the temporary
+ * file. In order to avoid a possible infinite loop, do not attempt to
+ * load further.
*/
+ /*
+ * Try to delete the file we probably created and then exit.
+ */
+
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
if (interp) {
@@ -3363,10 +3297,6 @@ Tcl_LoadFile(
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
- /*
- * Cross-platform copy failed.
- */
-
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
@@ -3374,10 +3304,9 @@ Tcl_LoadFile(
#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
- * attributes, and set any that are called "-permissions" to 0700. However
- * we just do this directly, like this:
+ * It might be necessary on some systems to set the appropriate permissions
+ * on the file. On Unix we could loop over the file attributes and set any
+ * that are called "-permissions" to 0700, but just do it directly instead:
*/
{
@@ -3394,8 +3323,8 @@ Tcl_LoadFile(
#endif
/*
- * We need to reset the result now, because the cross-filesystem copy may
- * have stored the number of bytes in the result.
+ * The cross-filesystem copy may have stored the number of bytes in the
+ * result, so reset the result now.
*/
if (interp) {
@@ -3405,30 +3334,24 @@ Tcl_LoadFile(
retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs,
&newLoadHandle);
if (retVal != TCL_OK) {
- /*
- * The file didn't load successfully.
- */
-
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
- * Try to delete the file immediately - this is possible in some OSes, and
- * avoids any worries about leaving the copy laying around on exit.
+ * Try to delete the file immediately. Some operatings systems allow this,
+ * and it avoids leaving the copy laying around after exit.
*/
- if (
- !skipUnlink (copyToPtr) &&
- (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
+ if (!skipUnlink(copyToPtr) &&
+ (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
/*
- * We tell our caller about the real shared library which was loaded.
- * Note that this does mean that the package list maintained by 'load'
- * will store the original (vfs) path alongside the temporary load
- * handle and unload proc ptr.
+ * Tell the caller all the details: The package list maintained by
+ * 'load' stores the original (vfs) pathname, the handle of object
+ * loaded from the temporary file, and the unloadProcPtr.
*/
*handlePtr = newLoadHandle;
@@ -3439,47 +3362,41 @@ Tcl_LoadFile(
}
/*
- * When we unload this file, we need to divert the unloading so we can
- * unload and cleanup the temporary file correctly.
+ * Divert the unloading in order to unload and cleanup the temporary file.
*/
- tvdlPtr = ckalloc(sizeof(FsDivertLoad));
+ tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad));
/*
- * Remember three pieces of information. This allows us to cleanup the
- * diverted load completely, on platforms which allow proper unloading of
- * code.
+ * Remember three pieces of information in order to clean up the diverted
+ * load completely on platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
if (copyFsPtr != &tclNativeFilesystem) {
- /*
- * copyToPtr is already incremented for this reference.
- */
-
+ /* refCount of copyToPtr is already incremented. */
tvdlPtr->divertedFile = copyToPtr;
/*
- * This is the filesystem we loaded it into. Since we have a reference
- * to 'copyToPtr', we already have a refCount on this filesystem, so
- * we don't need to worry about it disappearing on us.
+ * This is the filesystem for the temporary file the object was loaded
+ * from. A reference to copyToPtr is already stored in
+ * tvdlPtr->divertedFile, so need need to increment the refCount again.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/*
- * We need the native rep.
+ * Grab the native representation.
*/
tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));
/*
- * We don't need or want references to the copied Tcl_Obj or the
- * filesystem if it is the native one.
+ * Don't keeep a reference to the Tcl_Obj or the native filesystem.
*/
tvdlPtr->divertedFile = NULL;
@@ -3489,7 +3406,7 @@ Tcl_LoadFile(
copyToPtr = NULL;
- divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_));
+ divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
divertedLoadHandle->clientData = tvdlPtr;
divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
@@ -3502,8 +3419,8 @@ Tcl_LoadFile(
resolveSymbols:
/*
- * At this point, *handlePtr is already set up to the handle for the
- * loaded library. We now try to resolve the symbols.
+ * handlePtr now contains a token for the loaded object.
+ * Resolve the symbols.
*/
if (symbols != NULL) {
@@ -3512,9 +3429,8 @@ Tcl_LoadFile(
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.)
+ * file and return an error code. Tcl_FindSymbol should have
+ * already left an appropriate error message.
*/
(*handlePtr)->unloadFileProcPtr(*handlePtr);
@@ -3531,16 +3447,17 @@ Tcl_LoadFile(
*
* DivertFindSymbol --
*
- * Find a symbol in a shared library loaded by copy-from-VFS.
+ * Find a symbol in a shared library loaded by making a copying a file
+ * from the virtual filesystem to a native filesystem.
*
*----------------------------------------------------------------------
*/
static void *
DivertFindSymbol(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_LoadHandle loadHandle, /* Handle to the diverted module */
- const char *symbol) /* Symbol to resolve */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */
+ const char *symbol) /* The name of symbol to resolve. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
@@ -3553,83 +3470,75 @@ DivertFindSymbol(
*
* DivertUnloadFile --
*
- * Unloads a file that has been loaded by copying from VFS to the native
- * filesystem.
- *
- * Parameters:
- * loadHandle -- Handle of the file to unload
+ * Unloads an object that was loaded from a temporary file copied from the
+ * virtual filesystem the native filesystem.
*
*----------------------------------------------------------------------
*/
static void
DivertUnloadFile(
- Tcl_LoadHandle loadHandle)
+ Tcl_LoadHandle loadHandle) /* A handle for the loaded object. */
{
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) {
+ /*
+ * tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here.
+ */
+
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.
+ * Call the real 'unloadfile' proc. This must be called first so that the
+ * shared library is actually unloaded by the OS. Otherwise, the following
+ * 'delete' may fail because the shared library is still in use.
*/
originalHandle->unloadFileProcPtr(originalHandle);
/*
- * What filesystem contains the temp copy of the library?
+ * Determine which filesystem contains the temporary copy of the file.
*/
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.
+ * Use the function for the native filsystem, which works 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.
+ * Remove the temporary file. If encodings have been cleaned up
+ * already, this may crash.
*/
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).
+ * This may have happened because Tcl is exiting, and encodings may
+ * have already been deleted or something else the filesystem
+ * depends on may be gone.
*
- * In particular, one problem might be that the filesystem cannot
- * extract the information it needs from the above path object
+ * TO DO: Figure out how to delete this file more robustly, or
+ * give the filesystem the information it needs to delete the file
+ * more robustly. One problem might be that the filesystem cannot
+ * extract the information it needs from the above pathname 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.
+ * file) has been finalized and there is no way to get the native
+ * handle of the file.
*/
}
/*
- * 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.
+ * This also decrements the refCount of the Tcl_Filesystem
+ * corresponding to this file. which might cause the filesystem to be
+ * deallocated if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3644,23 +3553,23 @@ DivertUnloadFile(
*
* Tcl_FindSymbol --
*
- * Find a symbol in a loaded library
+ * Find a symbol in a loaded object.
*
- * Results:
- * Returns a pointer to the symbol if found. If not found, returns NULL
- * and leaves an error message in the interpreter result.
+ * Previously filesystem-specific, but has been made portable by having
+ * TclpDlopen return a structure that includes procedure pointers.
*
- * This function was once filesystem-specific, but has been made portable by
- * having TclpDlopen return a structure that includes procedure pointers.
+ * Results:
+ * Returns a pointer to the symbol if found. Otherwise, sets
+ * an error message in the interpreter result and returns NULL.
*
*----------------------------------------------------------------------
*/
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 */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */
+ const char *symbol) /* The name name of the symbol to resolve. */
{
return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol);
}
@@ -3670,16 +3579,15 @@ Tcl_FindSymbol(
*
* Tcl_FSUnloadFile --
*
- * Unloads a library given its handle. Checks first that the library
- * supports unloading.
+ * Unloads a loaded object if unloading is supported for the object.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnloadFile(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_LoadHandle handle) /* Handle of the file to unload */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle handle) /* A handle for the object to unload. */
{
if (handle->unloadFileProcPtr == NULL) {
if (interp != NULL) {
@@ -3700,52 +3608,45 @@ Tcl_FSUnloadFile(
*
* TclFSUnloadTempFile --
*
- * This function is called when we loaded a library of code via an
- * intermediate temporary file. This function ensures the library is
- * correctly unloaded and the temporary file is correctly deleted.
+ * Unloads an object loaded via temporary file from a virtual filesystem
+ * to a native filesystem.
*
* Results:
* None.
*
* Side effects:
- * The effects of the 'unload' function called, and of course the
- * temporary file will be deleted.
+ * Frees resources for the loaded object and deletes the temporary file.
*
*----------------------------------------------------------------------
*/
void
TclFSUnloadTempFile(
- Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
- * Tcl_FSLoadFile(). The loadHandle is a token
- * that represents the loaded file. */
+ Tcl_LoadHandle loadHandle) /* A handle for the object, as provided by a
+ * previous call to Tcl_FSLoadFile(). */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;
- /*
- * This test should never trigger, since we give the client data in the
- * function above.
- */
-
if (tvdlPtr == NULL) {
+ /*
+ * tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here.
+ */
return;
}
- /*
- * 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.
- */
-
if (tvdlPtr->unloadProcPtr != NULL) {
+ /*
+ * 'unloadProcPtr' must be called 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.
+ */
+
tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle);
}
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
+ * Call the function for the native fileystem, which works even at this
* late stage.
*/
@@ -3753,33 +3654,32 @@ TclFSUnloadTempFile(
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
- * Remove the temporary file we created. Note, we may crash here
- * because encodings have been taken down already.
+ * Remove the temporary file that was created. If encodings have
+ * already been freed because the interpreter is exiting this may
+ * crash.
*/
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.
+ * This may have happened because Tcl is exiting and encodings may
+ * have already been deleted, or something else the filesystem
+ * depends on may be gone.
*
- * 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
+ * TO DO: Figure out how to delete this file more robustly, or
+ * give the filesystem the information it needs to delete the file
+ * more robustly. One problem might be that the filesystem cannot
+ * extract the information it needs from the above pathname 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.
+ * file) has been finalized and there is no way to get the native
+ * handle of the file.
*/
}
/*
- * 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.
+ * This also decrements the refCount of the Tcl_Filesystem
+ * corresponding to this file. which might case filesystem to be freed
+ * if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3793,38 +3693,41 @@ TclFSUnloadTempFile(
*
* Tcl_FSLink --
*
- * This function replaces the library version of readlink() and can also
- * be used to make links. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Creates or inspects a link by calling 'linkProc' of the filesystem
+ * corresponding to the given pathname. Replaces the library version of
+ * readlink().
*
* Results:
- * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents
- * of the symbolic link given by 'pathPtr', or NULL if the symbolic link
- * could not be read. The result is owned by the caller, which should
- * call Tcl_DecrRefCount when the result is no longer needed.
+ * If toPtr is NULL, a Tcl_Obj containing the value the symbolic link for
+ * 'pathPtr', or NULL if a symbolic link was not accessible. The caller
+ * should Tcl_DecrRefCount on the result to release it. Otherwise NULL.
*
- * If toPtr is non-NULL, then the result is toPtr if the link action was
- * successful, or NULL if not. In this case the result has no additional
- * reference count, and need not be freed. The actual action to perform
- * is given by the 'linkAction' flags, which is an or'd combination of:
+ * In this case the result has no additional reference count and need not
+ * be freed. The actual action to perform is given by the 'linkAction'
+ * flags, which is a combination of:
*
* TCL_CREATE_SYMBOLIC_LINK
* TCL_CREATE_HARD_LINK
*
- * Note that most filesystems will not support linking across to
- * different filesystems, so this function will usually fail unless toPtr
- * is in the same FS as pathPtr.
+ * Most filesystems do not support linking across to different
+ * filesystems, so this function usually fails if the filesystem
+ * corresponding to toPtr is not the same as the filesystem corresponding
+ * to pathPtr.
*
* Side effects:
- * See readlink() documentation. A new filesystem link object may appear.
+ * Creates or sets a link if toPtr is not NULL.
+ *
+ * See readlink().
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(
- Tcl_Obj *pathPtr, /* Path of file to readlink or link. */
- Tcl_Obj *toPtr, /* NULL or path to be linked to. */
+ Tcl_Obj *pathPtr, /* Pathaname of file. */
+ Tcl_Obj *toPtr, /*
+ * NULL or the pathname of a file to link to.
+ */
int linkAction) /* Action to perform. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -3834,11 +3737,10 @@ Tcl_FSLink(
}
/*
- * If S_IFLNK isn't defined it means that the machine doesn't support
- * symbolic links, so the file can't possibly be a symbolic link. Generate
- * an EINVAL error, which is what happens on machines that do support
- * symbolic links when you invoke readlink on a file that isn't a symbolic
- * link.
+ * If S_IFLNK isn't defined the machine doesn't support symbolic links, so
+ * the file can't possibly be a symbolic link. Generate an EINVAL error,
+ * which is what happens on machines that do support symbolic links when
+ * readlink is called for a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
@@ -3854,16 +3756,9 @@ Tcl_FSLink(
*
* Tcl_FSListVolumes --
*
- * Lists the currently mounted volumes. The chain of functions that have
- * been "inserted" into the filesystem will be called in succession; each
- * may return a list of volumes, all of which are added to the result
- * until all mounted file systems are listed.
- *
- * Notice that we assume the lists returned by each filesystem (if non
- * NULL) have been given a refCount for us already. However, we are NOT
- * allowed to hang on to the list itself (it belongs to the filesystem we
- * called). Therefore we quite naturally add its contents to the result
- * we are building, and then decrement the refCount.
+ * Lists the currently mounted volumes by calling `listVolumesProc` of
+ * each registered filesystem, and combining the results to form a list of
+ * volumes.
*
* Results:
* The list of volumes, in an object which has refCount 0.
@@ -3880,14 +3775,13 @@ Tcl_FSListVolumes(void)
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr;
- TclNewObj(resultPtr);
/*
- * Call each of the "listVolumes" function in succession. A non-NULL
- * return value indicates the particular function has succeeded. We call
- * all the functions registered, since we want a list of all drives from
- * all filesystems.
+ * Call each "listVolumes" function of each registered filesystem in
+ * succession. A non-NULL return value indicates the particular function
+ * has succeeded.
*/
+ TclNewObj(resultPtr);
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
@@ -3896,6 +3790,12 @@ Tcl_FSListVolumes(void)
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
+ /*
+ * The refCount of each list returned by a `listVolumesProc`
+ * is already incremented. Do not hang onto the list, though.
+ * It belongs to the filesystem. Add its contents to the
+ * result we are building, and then decrement the refCount.
+ */
Tcl_DecrRefCount(thisFsVolumes);
}
}
@@ -3911,22 +3811,21 @@ Tcl_FSListVolumes(void)
*
* FsListMounts --
*
- * List all mounts within the given directory, which match the given
- * pattern.
+ * Lists the mounts mathing the given pattern in the given directory.
*
* Results:
- * The list of mounts, in a list object which has refCount 0, or NULL if
- * we didn't even find any filesystems to try to list mounts.
+ * A list, having a refCount of 0, of the matching mounts, or NULL if no
+ * search was performed because no filesystem provided a search routine.
*
* Side effects:
- * None
+ * None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
FsListMounts(
- Tcl_Obj *pathPtr, /* Contains path to directory to search. */
+ Tcl_Obj *pathPtr, /* Pathname of directory to search. */
const char *pattern) /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
@@ -3934,10 +3833,8 @@ FsListMounts(
Tcl_Obj *resultPtr = NULL;
/*
- * Call each of the "matchInDirectory" functions in succession, with the
- * specific type information 'mountsOnly'. A non-NULL return value
- * indicates the particular function has succeeded. We call all the
- * functions registered, since we want a list from each filesystems.
+ * Call the matchInDirectory function of each registered filesystem,
+ * passing it 'mountsOnly'. Results accumulate in resultPtr.
*/
fsRecPtr = FsGetFirstFilesystem();
@@ -3963,34 +3860,32 @@ FsListMounts(
*
* Tcl_FSSplitPath --
*
- * This function takes the given Tcl_Obj, which should be a valid path,
- * and returns a Tcl List object containing each segment of that path as
- * an element.
+ * Splits a pathname into its components.
*
* Results:
- * Returns list object with refCount of zero. If the passed in lenPtr is
- * non-NULL, we use it to return the number of elements in the returned
- * list.
+ * A list with refCount of zero.
*
* Side effects:
- * None.
+ * If lenPtr is not null, sets it to the number of elements in the result.
*
*---------------------------------------------------------------------------
*/
+#undef Tcl_FSSplitPath
Tcl_Obj *
Tcl_FSSplitPath(
- Tcl_Obj *pathPtr, /* Path to split. */
- int *lenPtr) /* int to store number of path elements. */
+ Tcl_Obj *pathPtr, /* The pathname to split. */
+ int *lenPtr) /* A place to hold the number of pathname
+ * elements. */
{
- Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
+ Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */
const Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
const char *p;
/*
- * Perform platform specific splitting.
+ * Perform platform-specific splitting.
*/
if (TclFSGetPathType(pathPtr, &fsPtr,
@@ -4002,9 +3897,7 @@ Tcl_FSSplitPath(
return TclpNativeSplitPath(pathPtr, lenPtr);
}
- /*
- * We assume separators are single characters.
- */
+ /* Assume each separator is a single character. */
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
@@ -4017,9 +3910,9 @@ Tcl_FSSplitPath(
}
/*
- * Place the drive name as first element of the result list. The drive
- * name may contain strange characters, like colons and multiple forward
- * slashes (for example 'ftp://' is a valid vfs drive name)
+ * Add the drive name as first element of the result. The drive name may
+ * contain strange characters like colons and sequences of forward slashes
+ * For example, 'ftp://' is a valid drive name.
*/
TclNewObj(result);
@@ -4029,7 +3922,7 @@ Tcl_FSSplitPath(
p += driveNameLength;
/*
- * Add the remaining path elements to the list.
+ * Add the remaining pathname elements to the list.
*/
for (;;) {
@@ -4056,12 +3949,8 @@ Tcl_FSSplitPath(
}
}
- /*
- * Compute the number of elements in the result.
- */
-
if (lenPtr != NULL) {
- TclListObjLength(NULL, result, lenPtr);
+ TclListObjLengthM(NULL, result, lenPtr);
}
return result;
}
@@ -4070,38 +3959,34 @@ Tcl_FSSplitPath(
*
* TclGetPathType --
*
- * Helper function used by FSGetPathType.
+ * Helper function used by TclFSGetPathType and TclJoinPath.
*
* Results:
- * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
- * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
- * only if it is non-NULL and the function's return value is
- * TCL_PATH_ABSOLUTE.
+ * One of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
- * None.
+ * See **filesystemPtrptr, *driveNameLengthPtr and **driveNameRef,
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclGetPathType(
- Tcl_Obj *pathPtr, /* Path to determine type for. */
+ Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
- /* If absolute path and this is not NULL, then
- * set to the filesystem which claims this
- * path. */
- int *driveNameLengthPtr, /* If the path is absolute, and this is
- * non-NULL, then set to the length of the
- * driveName. */
- Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
- * non-NULL, then set to the name of the
- * drive, network-volume which contains the
- * path, already with a refCount for the
- * caller. */
+ /* If not NULL, a place in which to store a
+ * pointer to the filesystem for this pathname
+ * if it is absolute. */
+ int *driveNameLengthPtr, /* If not NULL, a place in which to store the
+ * length of the volume name. */
+ Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
+ * place to store a pointer to an object with a
+ * refCount of 1, and whose value is the name
+ * of the volume. */
{
int pathLen;
- const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
@@ -4122,14 +4007,14 @@ TclGetPathType(
*
* TclFSNonnativePathType --
*
- * Helper function used by TclGetPathType. Its purpose is to check
- * whether the given path starts with a string which corresponds to a
- * file volume in any registered filesystem except the native one. For
- * speed and historical reasons the native filesystem has special
- * hard-coded checks dotted here and there in the filesystem code.
+ * Helper function used by TclGetPathType. Checks whether the given
+ * pathname starts with a string which corresponds to a file volume in
+ * some registered filesystem other than the native one. For speed and
+ * historical reasons the native filesystem has special hard-coded checks
+ * dotted here and there in the filesystem code.
*
* Results:
- * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
+ * One of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
* reference will be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
@@ -4141,49 +4026,45 @@ TclGetPathType(
Tcl_PathType
TclFSNonnativePathType(
- const char *path, /* Path to determine type for. */
- int pathLen, /* Length of the path. */
+ const char *path, /* Pathname to determine the type of. */
+ int pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
- /* If absolute path and this is not NULL, then
- * set to the filesystem which claims this
- * path. */
- int *driveNameLengthPtr, /* If the path is absolute, and this is
- * non-NULL, then set to the length of the
- * driveName. */
- Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
- * non-NULL, then set to the name of the
- * drive, network-volume which contains the
- * path, already with a refCount for the
- * caller. */
+ /* If not NULL, a place to store a pointer to
+ * the filesystem for this pathname when it is
+ * an absolute pathname. */
+ int *driveNameLengthPtr, /* If not NULL, a place to store the length of
+ * the volume name if the pathname is absolute.
+ */
+ Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to
+ * an object having its its refCount already
+ * incremented, and contining the name of the
+ * volume if the pathname is absolute. */
{
FilesystemRecord *fsRecPtr;
Tcl_PathType type = TCL_PATH_RELATIVE;
/*
- * Call each of the "listVolumes" function in succession, checking whether
- * the given path is an absolute path on any of the volumes returned (this
- * is done by checking whether the path's prefix matches).
+ * Determine whether the given pathname is an absolute pathname on some
+ * filesystem other than the native filesystem.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
/*
- * 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
- * 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.
+ * Skip the the native filesystem because otherwise some of the tests
+ * in the Tcl testsuite might fail because some of the tests
+ * artificially change the current platform (between win, unix) but the
+ * list of volumes obtained by calling fsRecPtr->fsPtr->listVolumesProc
+ * reflects the current (real) platform only. In particular, on Unix
+ * '/' matchs the beginning of certain absolute Windows pathnames
+ * starting '//' and those tests 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.
+ * There is another reason to skip the native filesystem: Since the
+ * tclFilename.c code has nice fast 'absolute path' checkers, there is
+ * no reason to waste time doing that in this frequently-called
+ * function. It is better to save the overhead of the native
+ * filesystem continuously returning a list of volumes.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
@@ -4192,16 +4073,15 @@ TclFSNonnativePathType(
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
- if (TclListObjLength(NULL, thisFsVolumes, &numVolumes)
+ if (TclListObjLengthM(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
* 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'.
+ * valid list. Set numVolumes to -1 to skip the 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).
+ * It would be better to signal an error here, but
+ * Tcl_Panic seems a bit excessive.
*/
numVolumes = -1;
@@ -4213,7 +4093,7 @@ TclFSNonnativePathType(
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
- strVol = Tcl_GetStringFromObj(vol,&len);
+ strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
@@ -4235,7 +4115,7 @@ TclFSNonnativePathType(
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/*
- * We don't need to examine any more filesystems.
+ * No need to to examine additional filesystems.
*/
break;
@@ -4253,12 +4133,13 @@ TclFSNonnativePathType(
*
* Tcl_FSRenameFile --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystems rename function. Otherwise we simply return the POSIX
- * error 'EXDEV', and -1.
+ * If the two pathnames correspond to the same filesystem, call
+ * 'renameFileProc' of that filesystem. Otherwise return the POSIX error
+ * 'EXDEV', and -1.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl error code if a rename function was called, or -1
+ * otherwise.
*
* Side effects:
* A file may be renamed.
@@ -4268,10 +4149,9 @@ TclFSNonnativePathType(
int
Tcl_FSRenameFile(
- Tcl_Obj *srcPathPtr, /* Pathname of file or dir to be renamed
- * (UTF-8). */
- Tcl_Obj *destPathPtr) /* New pathname of file or directory
- * (UTF-8). */
+ Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be
+ renamed. */
+ Tcl_Obj *destPathPtr) /* The new pathname for the file. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4294,27 +4174,27 @@ Tcl_FSRenameFile(
*
* Tcl_FSCopyFile --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystem's copy function. Otherwise we simply return the POSIX error
- * 'EXDEV', and -1.
+ * If both pathnames correspond to the same filesystem, calls
+ * 'copyFileProc' of that filesystem.
*
- * Note that in the native filesystems, 'copyFileProc' is defined to copy
- * soft links (i.e. it copies the links themselves, not the things they
- * point to).
+ * In the native filesystems, 'copyFileProc' copies a link itself, not the
+ * thing the link points to.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl return code if a copyFileProc was called, or -1
+ * otherwise.
*
* Side effects:
- * A file may be copied.
+ * A file might be copied. The POSIX error 'EXDEV' is set if a copy
+ * function was not called.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyFile(
- Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */
- Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */
+ Tcl_Obj *srcPathPtr, /* The pathname of file to be copied. */
+ Tcl_Obj *destPathPtr) /* The new pathname to copy the file to. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4336,15 +4216,14 @@ Tcl_FSCopyFile(
*
* TclCrossFilesystemCopy --
*
- * Helper for above function, and for Tcl_FSLoadFile, to copy files from
- * one filesystem to another. This function will overwrite the target
- * file if it already exists.
+ * Helper for Tcl_FSCopyFile and Tcl_FSLoadFile. Copies a file from one
+ * filesystem to another, overwiting any file that already exists.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code.
*
* Side effects:
- * A file may be created.
+ * A file may be copied.
*
*---------------------------------------------------------------------------
*/
@@ -4352,8 +4231,8 @@ Tcl_FSCopyFile(
int
TclCrossFilesystemCopy(
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). */
+ Tcl_Obj *source, /* Pathname of file to be copied. */
+ Tcl_Obj *target) /* Pathname to copy the file to. */
{
int result = TCL_ERROR;
int prot = 0666;
@@ -4364,7 +4243,7 @@ TclCrossFilesystemCopy(
out = Tcl_FSOpenFileChannel(interp, target, "wb", prot);
if (out == NULL) {
/*
- * It looks like we cannot copy it over. Bail out...
+ * Failed to open an output channel. Bail out.
*/
goto done;
}
@@ -4372,7 +4251,7 @@ TclCrossFilesystemCopy(
in = Tcl_FSOpenFileChannel(interp, source, "rb", prot);
if (in == NULL) {
/*
- * This is very strange, caller should have checked this...
+ * Could not open an input channel. Why didn't the caller check this?
*/
Tcl_Close(interp, out);
@@ -4380,8 +4259,8 @@ TclCrossFilesystemCopy(
}
/*
- * Copy it synchronously. We might wish to add an asynchronous option to
- * support vfs's which are slow (e.g. network sockets).
+ * Copy the file synchronously. TO DO: Maybe add an asynchronous option
+ * to support virtual filesystems that are slow (e.g. network sockets).
*/
if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
@@ -4389,7 +4268,7 @@ TclCrossFilesystemCopy(
}
/*
- * If the copy failed, assume that copy channel left a good error message.
+ * If the copy failed, assume that copy channel left an error message.
*/
Tcl_Close(interp, in);
@@ -4414,11 +4293,11 @@ TclCrossFilesystemCopy(
*
* Tcl_FSDeleteFile --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'deleteFileProc' of the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code.
*
* Side effects:
* A file may be deleted.
@@ -4444,14 +4323,15 @@ Tcl_FSDeleteFile(
*
* Tcl_FSCreateDirectory --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'createDirectoryProc' of the filesystem corresponding to the
+ * given pathname.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code, or -1 if no createDirectoryProc is found.
*
* Side effects:
- * A directory may be created.
+ * A directory may be created. POSIX error 'ENOENT' is set if no
+ * createDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
@@ -4474,27 +4354,29 @@ Tcl_FSCreateDirectory(
*
* Tcl_FSCopyDirectory --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystems copy-directory function. Otherwise we simply return the
- * POSIX error 'EXDEV', and -1.
+ * If both pathnames correspond to the the same filesystem, calls
+ * 'copyDirectoryProc' of that filesystem.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found.
*
* Side effects:
- * A directory may be copied.
+ * A directory may be copied. POSIX error 'EXDEV' is set if no
+ * copyDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyDirectory(
- 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
- * object containing name of file causing
- * error, with refCount 1. */
+ Tcl_Obj *srcPathPtr, /* The pathname of the directory to be
+ * copied. */
+ Tcl_Obj *destPathPtr, /* The pathname of the target directory. */
+ Tcl_Obj **errorPtr) /* If not NULL, and there is an error, a place
+ * to store a pointer to a new object, with
+ * its refCount already incremented, and
+ * containing the pathname name of file
+ * causing the error. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4516,28 +4398,31 @@ Tcl_FSCopyDirectory(
*
* Tcl_FSRemoveDirectory --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'removeDirectoryProc' of the filesystem corresponding to remove
+ * pathPtr.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code, or -1 if no removeDirectoryProc is found.
*
* Side effects:
- * A directory may be deleted.
+ * A directory may be removed. POSIX error 'ENOENT' is set if no
+ * removeDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(
- Tcl_Obj *pathPtr, /* Pathname of directory to be removed
- * (UTF-8). */
- int recursive, /* If non-zero, removes directories that are
- * nonempty. Otherwise, will only remove empty
- * directories. */
- Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new
- * object containing name of file causing
- * error, with refCount 1. */
+ Tcl_Obj *pathPtr, /* The pathname of the directory to be removed.
+ */
+ int recursive, /* If zero, removes only an empty directory.
+ * Otherwise, removes the directory and all its
+ * contents. */
+ Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a
+ * place to store a a pointer to a new
+ * object having a refCount of 1 and containing
+ * the name of the file that produced an error.
+ * */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -4546,27 +4431,21 @@ Tcl_FSRemoveDirectory(
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) {
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);
+ normPathStr = TclGetStringFromObj(normPath, &normLen);
+ cwdStr = TclGetStringFromObj(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]'.
+ * The cwd is inside the directory to be removed. Change
+ * the cwd to [file dirname $path].
*/
Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
@@ -4587,16 +4466,14 @@ Tcl_FSRemoveDirectory(
*
* Tcl_FSGetFileSystemForPath --
*
- * This function determines which filesystem to use for a particular path
- * object, and returns the filesystem which accepts this file. If no
- * filesystem will accept this object as a valid file path, then NULL is
- * returned.
+ * Produces the filesystem that corresponds to the given pathname.
*
* Results:
- * NULL or a filesystem which will accept this path.
+ * The corresponding Tcl_Filesystem, or NULL if the pathname is invalid.
*
* Side effects:
- * The object may be converted to a path type.
+ * The internal representation of fsPtrPtr is converted to fsPathType if
+ * needed, and that internal representation is updated as needed.
*
*---------------------------------------------------------------------------
*/
@@ -4613,41 +4490,38 @@ Tcl_FSGetFileSystemForPath(
return NULL;
}
- /*
- * If the object has a refCount of zero, we reject it. This is to avoid
- * possible segfaults or nondeterministic memory leaks (i.e. the user
- * doesn't know if they should decrement the ref count on return or not).
- */
-
if (pathPtr->refCount == 0) {
+ /*
+ * Avoid possible segfaults or nondeterministic memory leaks where the
+ * reference count has been incorreclty managed.
+ */
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
- /*
- * Check if the filesystem has changed in some way since this object's
- * internal representation was calculated. Before doing that, assure we
- * have the most up-to-date copy of the first filesystem. This is
- * accomplished by the FsGetFirstFilesystem() call.
- */
-
+ /* Start with an up-to-date copy of the filesystem. */
fsRecPtr = FsGetFirstFilesystem();
Claim();
+ /*
+ * Ensure that pathPtr is a valid pathname.
+ */
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
+ /* not a valid pathname */
Disclaim();
return NULL;
} else if (retVal != NULL) {
- /* TODO: Can this happen? */
+ /*
+ * Found the filesystem in the internal representation of pathPtr.
+ */
Disclaim();
return retVal;
}
/*
- * Call each of the "pathInFilesystem" functions in succession. A
- * non-return value of -1 indicates the particular function has succeeded.
+ * Call each of the "pathInFilesystem" functions in succession until the
+ * corresponding filesystem is found.
*/
-
for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) {
ClientData clientData = NULL;
@@ -4656,10 +4530,10 @@ Tcl_FSGetFileSystemForPath(
}
if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
- /*
- * We assume the type of pathPtr hasn't been changed by the above
- * call to the pathInFilesystemProc.
- */
+ /* This is the filesystem for pathPtr. Assume the type of pathPtr
+ * hasn't been changed by the above call to the
+ * pathInFilesystemProc, and cache this result in the internal
+ * representation of pathPtr. */
TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
Disclaim();
@@ -4676,26 +4550,7 @@ Tcl_FSGetFileSystemForPath(
*
* Tcl_FSGetNativePath --
*
- * This function is for use by the Win/Unix native filesystems, so that
- * they can easily retrieve the native (char* or WCHAR*) representation
- * of a path. Other filesystems will probably want to implement similar
- * functions. They basically act as a safety net around
- * Tcl_FSGetInternalRep. Normally your file-system functions will always
- * be called with path objects already converted to the correct
- * filesystem, but if for some reason they are called directly (i.e. by
- * 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 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.
- *
- * Results:
- * NULL or a valid native path.
- *
- * Side effects:
- * See Tcl_FSGetInternalRep.
+ * See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
@@ -4712,7 +4567,7 @@ Tcl_FSGetNativePath(
*
* NativeFreeInternalRep --
*
- * Free a native internal representation, which will be non-NULL.
+ * Free a native internal representation.
*
* Results:
* None.
@@ -4734,16 +4589,17 @@ NativeFreeInternalRep(
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
+ * Produce the type of a pathname and the type of its filesystem.
*
- * This function returns a list of two elements. The first element is the
- * name of the filesystem (e.g. "native" or "vfs"), and the second is the
- * particular type of the given path within that filesystem.
*
* Results:
- * A list of two elements.
+ * A list where the first item is the name of the filesystem (e.g.
+ * "native" or "vfs"), and the second item is the type of the given
+ * pathname within that filesystem.
*
* Side effects:
- * The object may be converted to a path type.
+ * The internal representation of pathPtr may be converted to a
+ * fsPathType.
*
*---------------------------------------------------------------------------
*/
@@ -4779,16 +4635,13 @@ Tcl_FSFileSystemInfo(
*
* Tcl_FSPathSeparator --
*
- * This function returns the separator to be used for a given path. The
- * object returned should have a refCount of zero
+ * Produces the separator for given pathname.
*
* Results:
- * A Tcl object, with a refCount of zero. If the caller needs to retain a
- * reference to the object, it should call Tcl_IncrRefCount, and should
- * otherwise free the object.
+ * A Tcl object having a refCount of zero.
*
* Side effects:
- * The path object may be converted to a path type.
+ * The internal representation of pathPtr may be converted to a fsPathType
*
*---------------------------------------------------------------------------
*/
@@ -4809,8 +4662,8 @@ Tcl_FSPathSeparator(
}
/*
- * Allow filesystems not to provide a filesystemSeparatorProc if they wish
- * to use the standard forward slash.
+ * Use the standard forward slash character if filesystem does not to
+ * provide a filesystemSeparatorProc.
*/
TclNewLiteralStringObj(resultObj, "/");
@@ -4822,11 +4675,11 @@ Tcl_FSPathSeparator(
*
* NativeFilesystemSeparator --
*
- * This function is part of the native filesystem support, and returns
- * the separator for the given path.
+ * This function, part of the native filesystem support, returns the
+ * separator for the given pathname.
*
* Results:
- * String object containing the separator character.
+ * The separator character.
*
* Side effects:
* None.
@@ -4836,9 +4689,9 @@ Tcl_FSPathSeparator(
static Tcl_Obj *
NativeFilesystemSeparator(
- Tcl_Obj *pathPtr)
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
- const char *separator = NULL; /* lint */
+ const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index b17b224..79be731 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -5,9 +5,9 @@
* to lookup a keyword in a table of valid values and cache the index of
* 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.
+ * Copyright © 1990-1994 The Regents of the University of California.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 2006 Sam Bromley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -25,15 +25,9 @@ static int GetIndexFromObjList(Tcl_Interp *interp,
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 Tcl_ObjCmdProc PrefixAllObjCmd;
+static Tcl_ObjCmdProc PrefixLongestObjCmd;
+static Tcl_ObjCmdProc PrefixMatchObjCmd;
static void PrintUsage(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable);
@@ -100,6 +94,7 @@ typedef struct {
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
@@ -113,6 +108,7 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
+ if (!(flags & TCL_INDEX_TEMP_TABLE)) {
/*
* See if there is a valid cached result from a previous lookup (doing the
@@ -120,8 +116,10 @@ Tcl_GetIndexFromObj(
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &indexType);
+
+ if (irPtr) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -134,9 +132,11 @@ Tcl_GetIndexFromObj(
return TCL_OK;
}
}
+ }
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -184,7 +184,7 @@ GetIndexFromObjList(
* of the code there. This is a bit ineffiecient but simpler.
*/
- result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv);
+ result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
@@ -210,13 +210,8 @@ GetIndexFromObjList(
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
- sizeof(char *), msg, flags, indexPtr);
+ sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr);
- /*
- * The internal rep must be cleared since tablePtr will go away.
- */
-
- TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
@@ -234,11 +229,12 @@ GetIndexFromObjList(
* Results:
* If the value of objPtr is identical to or a unique abbreviation for
* 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 like 'bad option "foo": must
+ * the index of the matching entry is stored at *indexPtr
+ * (unless indexPtr is NULL). 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 like 'bad option "foo": must
* be ...'
*
* Side effects:
@@ -248,6 +244,7 @@ GetIndexFromObjList(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetIndexFromObjStruct
int
Tcl_GetIndexFromObjStruct(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
@@ -260,8 +257,8 @@ Tcl_GetIndexFromObjStruct(
int offset, /* The number of bytes between entries */
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 flags, /* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */
+ void *indexPtr) /* Place to store resulting index. */
{
int index, idx, numAbbrev;
const char *key, *p1;
@@ -269,6 +266,7 @@ Tcl_GetIndexFromObjStruct(
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ const Tcl_ObjInternalRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
@@ -278,15 +276,18 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr && (objPtr->typePtr == &indexType)) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchInternalRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if ((indexRep->tablePtr == tablePtr)
&& (indexRep->offset == offset)
&& (indexRep->index >= 0)) {
- *indexPtr = indexRep->index;
- return TCL_OK;
+ index = indexRep->index;
+ goto uncachedDone;
}
}
+ }
/*
* Lookup the value of the object in the table. Accept unique
@@ -297,6 +298,9 @@ Tcl_GetIndexFromObjStruct(
index = -1;
numAbbrev = 0;
+ if (!*key && (flags & TCL_NULL_OK)) {
+ goto uncachedDone;
+ }
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
@@ -341,21 +345,42 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr && (index >= 0)) {
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- } else {
- TclFreeIntRep(objPtr);
- indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
- }
- indexRep->tablePtr = (void *) tablePtr;
- indexRep->offset = offset;
- indexRep->index = index;
+ if (objPtr && (index >= 0) && !(flags & TCL_INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchInternalRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
+ } else {
+ Tcl_ObjInternalRep ir;
+
+ indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
+ ir.twoPtrValue.ptr1 = indexRep;
+ Tcl_StoreInternalRep(objPtr, &indexType, &ir);
+ }
+ indexRep->tablePtr = (void *) tablePtr;
+ indexRep->offset = offset;
+ indexRep->index = index;
}
- *indexPtr = index;
+ uncachedDone:
+ if (indexPtr != NULL) {
+ flags &= (30-(int)(sizeof(int)<<1));
+ if (flags) {
+ if (flags == sizeof(uint16_t)<<1) {
+ *(uint16_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(uint8_t)<<1)) {
+ *(uint8_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(int64_t)<<1)) {
+ *(int64_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(int32_t)<<1)) {
+ *(int32_t *)indexPtr = index;
+ return TCL_OK;
+ }
+ }
+ *(int *)indexPtr = index;
+ }
return TCL_OK;
error:
@@ -381,7 +406,7 @@ Tcl_GetIndexFromObjStruct(
*entryPtr, NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
- if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
+ if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) {
Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
" or ", *entryPtr, NULL);
} else if (**entryPtr) {
@@ -390,6 +415,9 @@ Tcl_GetIndexFromObjStruct(
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
+ if ((flags & TCL_NULL_OK)) {
+ Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL);
+ }
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
@@ -418,16 +446,10 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = (IndexRep *)objPtr->internalRep.twoPtrValue.ptr1;
- char *buf;
- unsigned len;
+ IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
- len = strlen(indexStr);
- buf = ckalloc(len + 1);
- memcpy(buf, indexStr, len+1);
- objPtr->bytes = buf;
- objPtr->length = len;
+ Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
@@ -453,12 +475,14 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = (IndexRep *)srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_ObjInternalRep ir;
IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep));
- memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &indexType)->twoPtrValue.ptr1,
+ sizeof(IndexRep));
+
+ ir.twoPtrValue.ptr1 = dupIndexRep;
+ Tcl_StoreInternalRep(dupPtr, &indexType, &ir);
}
/*
@@ -482,7 +506,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ ckfree(TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -539,7 +563,7 @@ TclInitPrefixCmd(
static int
PrefixMatchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -588,7 +612,7 @@ PrefixMatchObjCmd(
return TCL_ERROR;
}
i++;
- result = TclListObjLength(interp, objv[i], &errorLength);
+ result = TclListObjLengthM(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -612,7 +636,7 @@ PrefixMatchObjCmd(
* error case regardless of level.
*/
- result = TclListObjLength(interp, tablePtr, &dummyLength);
+ result = TclListObjLengthM(interp, tablePtr, &dummyLength);
if (result != TCL_OK) {
return result;
}
@@ -632,7 +656,7 @@ PrefixMatchObjCmd(
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
- Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result));
return Tcl_SetReturnOptions(interp, errorPtr);
}
@@ -663,7 +687,7 @@ PrefixMatchObjCmd(
static int
PrefixAllObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -677,15 +701,15 @@ PrefixAllObjCmd(
return TCL_ERROR;
}
- result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
- string = Tcl_GetStringFromObj(objv[2], &length);
+ string = TclGetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
- elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+ elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
@@ -720,7 +744,7 @@ PrefixAllObjCmd(
static int
PrefixLongestObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -734,17 +758,17 @@ PrefixLongestObjCmd(
return TCL_ERROR;
}
- result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
- string = Tcl_GetStringFromObj(objv[2], &length);
+ string = TclGetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
- elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+ elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
@@ -784,7 +808,7 @@ PrefixLongestObjCmd(
* Adjust in case we stopped in the middle of a UTF char.
*/
- resultLength = TclUtfPrev(&resultString[i+1],
+ resultLength = Tcl_UtfPrev(&resultString[i+1],
resultString) - resultString;
break;
}
@@ -850,7 +874,7 @@ Tcl_WrongNumArgs(
Tcl_Obj *objPtr;
int i, len, elemLen;
char flags;
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
const char *elementStr;
/*
@@ -921,10 +945,10 @@ Tcl_WrongNumArgs(
/*
* Add the element, quoting it if necessary.
*/
+ const Tcl_ObjInternalRep *irPtr;
- if (origObjv[i]->typePtr == &indexType) {
- IndexRep *indexRep =
- origObjv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(origObjv[i], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
@@ -970,9 +994,10 @@ Tcl_WrongNumArgs(
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
+ const Tcl_ObjInternalRep *irPtr;
- if (objv[i]->typePtr == &indexType) {
- IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(objv[i], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
@@ -1047,6 +1072,7 @@ Tcl_WrongNumArgs(
*----------------------------------------------------------------------
*/
+#undef Tcl_ParseArgsObjv
int
Tcl_ParseArgsObjv(
Tcl_Interp *interp, /* Place to store error message. */
@@ -1109,7 +1135,7 @@ Tcl_ParseArgsObjv(
curArg = objv[srcIndex];
srcIndex++;
objc--;
- str = Tcl_GetStringFromObj(curArg, &length);
+ str = TclGetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
@@ -1416,7 +1442,7 @@ TclGetCompletionCodeFromObj(
"ok", "error", "return", "break", "continue", NULL
};
- if ((value->typePtr != &indexType)
+ if (!TclHasInternalRep(value, &indexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index c75c2e1..4db3919 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -24,23 +24,9 @@ scspec EXTERN
# Use at your own risk. Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 0 {
-# int TclAccess(const char *path, int mode)
-#}
-#declare 1 {
-# int TclAccessDeleteProc(TclAccessProc_ *proc)
-#}
-#declare 2 {
-# int TclAccessInsertProc(TclAccessProc_ *proc)
-#}
declare 3 {
void TclAllocateFreeObjects(void)
}
-# Replaced by TclpChdir in 8.1:
-# declare 4 {
-# int TclChdir(Tcl_Interp *interp, char *dirName)
-# }
declare 5 {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
@@ -51,7 +37,7 @@ declare 6 {
declare 7 {
int TclCopyAndCollapse(int count, const char *src, char *dst)
}
-declare 8 {
+declare 8 {deprecated {}} {
int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
@@ -74,37 +60,12 @@ declare 11 {
declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
-# Removed in 8.5:
-#declare 13 {
-# int TclDoGlob(Tcl_Interp *interp, char *separators,
-# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
-#}
declare 14 {
- int TclDumpMemoryInfo(ClientData clientData, int flags)
+ int TclDumpMemoryInfo(void *clientData, int flags)
}
-# Removed in 8.1:
-# declare 15 {
-# void TclExpandParseValue(ParseValue *pvPtr, int needed)
-# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-# Removed in 8.4:
-#declare 17 {
-# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
-#}
-#declare 18 {
-# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 19 {
-# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 20 {
-# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 21 {
-# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
@@ -115,32 +76,14 @@ declare 23 {
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
declare 24 {
- int TclFormatInt(char *buffer, long n)
+ int TclFormatInt(char *buffer, Tcl_WideInt n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
-# Removed in 8.1:
-# declare 26 {
-# char *TclGetCwd(Tcl_Interp *interp)
-# }
-# Removed in 8.5:
-#declare 27 {
-# int TclGetDate(char *p, unsigned long now, long zone,
-# unsigned long *timePtr)
-#}
declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
-# Removed in 8.4b2:
-#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 {
-# char *TclGetEnv(const char *name)
-# }
declare 31 {
const char *TclGetExtension(const char *name)
}
@@ -148,23 +91,10 @@ declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-# Removed in 8.5:
-#declare 33 {
-# TclCmdProcType TclGetInterpProc(void)
-#}
-declare 34 {
+declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-# Removed in 8.4b2:
-#declare 35 {
-# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# int flags)
-#}
-# 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)
}
@@ -184,13 +114,11 @@ declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
- CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
+ const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
+}
+declare 43 {
+ Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void)
}
-# Removed in 8.5a2:
-#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
declare 44 {
int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
@@ -200,20 +128,6 @@ declare 45 {
declare 46 {
int TclInExit(void)
}
-# Removed in 8.4b2:
-#declare 47 {
-# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp,
-# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
-#}
-# Removed in 8.4b2:
-#declare 48 {
-# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
-# long incrAmount)
-#}
-#declare 49 {
-# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
-#}
declare 50 {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
@@ -221,42 +135,22 @@ declare 50 {
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-# Removed in 8.5a2:
-#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
declare 53 {
- int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+ int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp,
+ int argc, const char **argv)
}
declare 54 {
- int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
+ int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
-# Replaced with TclpLoadFile in 8.1:
-# 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 {
-# int TclLooksLikeInt(char *p)
-# }
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 {
-# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
-# Tcl_DString *dirPtr, char *pattern, char *tail)
-#}
declare 60 {
int TclNeedSpace(const char *start, const char *end)
}
@@ -267,46 +161,18 @@ declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
- int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
+ int TclObjInterpProc(void *clientData, 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 8.5a2:
-#declare 65 {
-# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
-# Tcl_Obj *const objv[], int flags)
-#}
-#declare 66 {
-# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc)
-#}
-#declare 67 {
-# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
-#}
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 68 {
-# int TclpAccess(const char *path, int mode)
-#}
declare 69 {
- char *TclpAlloc(unsigned int size)
+ void *TclpAlloc(unsigned int size)
}
-#declare 70 {
-# int TclpCopyFile(const char *source, const char *dest)
-#}
-#declare 71 {
-# int TclpCopyDirectory(const char *source, const char *dest,
-# Tcl_DString *errorPtr)
-#}
-#declare 72 {
-# int TclpCreateDirectory(const char *path)
-#}
-#declare 73 {
-# int TclpDeleteFile(const char *path)
-#}
declare 74 {
- void TclpFree(char *ptr)
+ void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
@@ -314,62 +180,20 @@ declare 75 {
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
-# Removed in 8.6:
-#declare 78 {
-# int TclpGetTimeZone(unsigned long time)
-#}
-# Replaced by Tcl_FSListVolumes in 8.4:
-#declare 79 {
-# int TclpListVolumes(Tcl_Interp *interp)
-#}
-# Replaced by Tcl_FSOpenFileChannel in 8.4:
-#declare 80 {
-# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
-# char *modeString, int permissions)
-#}
declare 81 {
- char *TclpRealloc(char *ptr, unsigned int size)
+ void *TclpRealloc(void *ptr, unsigned int size)
}
-#declare 82 {
-# int TclpRemoveDirectory(const char *path, int recursive,
-# Tcl_DString *errorPtr)
-#}
-#declare 83 {
-# int TclpRenameFile(const char *source, const char *dest)
-#}
-# Removed in 8.1:
-# declare 84 {
-# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
-# ParseValue *pvPtr)
-# }
-# declare 85 {
-# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
-# char **termPtr, ParseValue *pvPtr)
-# }
-# declare 86 {
-# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
-# int flags, char **termPtr, ParseValue *pvPtr)
-# }
-# declare 87 {
-# void TclPlatformInit(Tcl_Interp *interp)
-# }
-declare 88 {
- char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
+declare 88 {deprecated {}} {
+ char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
}
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 {
-# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
-# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
@@ -379,17 +203,8 @@ declare 92 {
const char *procName)
}
declare 93 {
- void TclProcDeleteProc(ClientData clientData)
+ void TclProcDeleteProc(void *clientData)
}
-# Removed in 8.5:
-#declare 94 {
-# int TclProcInterpProc(void *clientData, Tcl_Interp *interp,
-# int argc, const char **argv)
-#}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 95 {
-# int TclpStat(const char *path, Tcl_StatBuf *buf)
-#}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName)
@@ -400,18 +215,8 @@ declare 97 {
declare 98 {
int TclServiceIdle(void)
}
-# Removed in 8.4b2:
-#declare 99 {
-# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
-#}
-# Removed in 8.4b2:
-#declare 100 {
-# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *objPtr, int flags)
-#}
declare 101 {
- CONST86 char *TclSetPreInitScript(const char *string)
+ const char *TclSetPreInitScript(const char *string)
}
declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
@@ -420,19 +225,9 @@ declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 {
+declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 105 {
-# int TclStat(const char *path, Tcl_StatBuf *buf)
-#}
-#declare 106 {
-# int TclStatDeleteProc(TclStatProc_ *proc)
-#}
-#declare 107 {
-# int TclStatInsertProc(TclStatProc_ *proc)
-#}
declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
@@ -442,10 +237,6 @@ declare 109 {
declare 110 {
int TclSockMinimumBuffers(void *sock, int size)
}
-# Removed in 8.1:
-# 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.
@@ -456,26 +247,26 @@ declare 111 {
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
- ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
+ void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+ void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
declare 116 {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+ Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
+ Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
@@ -491,28 +282,28 @@ declare 120 {
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+ Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+ void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
@@ -530,44 +321,22 @@ declare 131 {
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 132 {
+declare 132 {deprecated {}} {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 {
+declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
-# Removed in 8.5
-#declare 134 {
-# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
-# const struct tm *t, int useGMT)
-#}
-#declare 135 {
-# int TclpCheckStackSpace(void)
-#}
-
-# Added in 8.1:
-
-#declare 137 {
-# int TclpChdir(const char *dirName)
-#}
declare 138 {
- CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
+ const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
-#declare 139 {
-# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
-# char *sym2, Tcl_PackageInitProc **proc1Ptr,
-# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr)
-#}
-#declare 140 {
-# int TclLooksLikeInt(const char *bytes, int length)
-#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
- CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+ const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CompileHookProc *hookProc, ClientData clientData)
+ CompileHookProc *hookProc, void *clientData)
}
declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
@@ -592,9 +361,6 @@ declare 148 {
declare 149 {
void TclHandleRelease(TclHandle handle)
}
-
-# Added for Tcl 8.2
-
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
@@ -608,17 +374,6 @@ declare 152 {
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
-
-# moved to tclTest.c (static) in 8.3.2/8.4a2
-#declare 154 {
-# int TclTestChannelCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 155 {
-# int TclTestChannelEventCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
@@ -626,27 +381,19 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 158 {
+declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 159 {
+declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
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 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
- void TclChannelEventScriptInvoker(ClientData clientData, int flags)
+ void TclChannelEventScriptInvoker(void *clientData, int flags)
}
# ALERT: The result of 'TclGetInstructionTable' is actually a
@@ -677,13 +424,10 @@ declare 166 {
int index, Tcl_Obj *valuePtr)
}
-# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 167 {
+declare 167 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 168 {
+declare 168 {deprecated {use public Tcl_GetStartupScript()}} {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
@@ -703,23 +447,10 @@ declare 171 {
declare 172 {
int TclInThreadExit(void)
}
-
-# added for 8.4.2
-
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 {
-# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
-#}
-
-# Factoring out of trace code
-
declare 175 {
int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
const char *part1, const char *part2, int flags, int leaveErrMsg)
@@ -731,95 +462,25 @@ 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 too
declare 178 {
- void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+ void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
- Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+ Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
-
-# REMOVED
-# Allocate lists without copying arrays
-# declare 180 {
-# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
-# }
-#declare 181 {
-# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
-# const char *file, int line)
-#}
-
-# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
-
-declare 182 {
+declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 {
+declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
-### REMOVED on grounds it should never have been exposed. All these
-### functions are now either static in tclThreadStorage.c or
-### MODULE_SCOPE.
-# declare 184 {
-# void TclThreadStorageLockInit(void)
-# }
-# declare 185 {
-# void TclThreadStorageLock(void)
-# }
-# declare 186 {
-# void TclThreadStorageUnlock(void)
-# }
-# declare 187 {
-# void TclThreadStoragePrint(FILE *outFile, int flags)
-# }
-# declare 188 {
-# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)
-# }
-# declare 189 {
-# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)
-# }
-# declare 190 {
-# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 191 {
-# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 192 {
-# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)
-# }
-# declare 193 {
-# void TclFinalizeThreadStorageThread(Tcl_ThreadId id)
-# }
-# declare 194 {
-# void TclFinalizeThreadStorage(void)
-# }
-# declare 195 {
-# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 196 {
-# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)
-# }
-
-#
-# Added in tcl8.5a5 for compiler/executor experimentation.
-# Disabled in Tcl 8.5.1; experiments terminated. :/
-#
-#declare 197 {
-# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
-# const CmdFrame *invoker, int word)
-#}
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
-
-#declare 199 {
-# int TclMatchIsTrivial(const char *pattern)
-#}
-
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
@@ -888,8 +549,6 @@ declare 218 {
declare 224 {
TclPlatformType *TclGetPlatform(void)
}
-
-#
declare 225 {
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
@@ -901,12 +560,6 @@ declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
-# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
-# core and NRE-enabled
-# declare 228 {
-# int TclObjInterpProcCore(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)
@@ -938,10 +591,7 @@ declare 234 {
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
-
-
-# TIP 337 made this one public
-declare 236 {
+declare 236 {deprecated {use Tcl_BackgroundException}} {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
@@ -953,7 +603,7 @@ declare 237 {
# 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 TclNRInterpProc(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 239 {
@@ -995,7 +645,7 @@ declare 247 {
declare 248 {
int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
- Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr)
+ Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr)
}
declare 249 {
@@ -1004,13 +654,13 @@ declare 249 {
}
# TIP #285: Script cancellation support.
declare 250 {
- void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
+ void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
- char *bytes, int length, int flags)
+ const char *bytes, int length, int flags)
}
# Exporting of the internal API to variables.
@@ -1038,14 +688,25 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags)
}
-
declare 257 {
- void TclStaticPackage(Tcl_Interp *interp, const char *prefix,
- Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+ void TclStaticLibrary(Tcl_Interp *interp, const char *prefix,
+ Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
+# TIP 431: temporary directory creation function
+declare 258 {
+ Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+}
+
+# TIP 625: for unit testing - create list objects with span
+declare 260 {
+ Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace)
+}
+
+# TIP 625: for unit testing - check list invariants
declare 261 {
- void TclUnusedStubEntry(void)
+ void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
}
##############################################################################
@@ -1075,14 +736,9 @@ declare 3 win {
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
-# Removed in 8.1:
-# declare 5 win {
-# HINSTANCE TclWinLoadLibrary(char *name)
-# }
declare 6 win {
unsigned short TclWinNToHS(unsigned short ns)
}
@@ -1096,14 +752,9 @@ declare 8 win {
declare 9 win {
int TclWinGetPlatformId(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
-# Removed in 8.3.1 (for Win32s only)
-#declare 10 win {
-# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
-#}
# Pipe channel functions
@@ -1125,18 +776,9 @@ declare 15 win {
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 16 win {
int TclpIsAtty(int fd)
}
-# Signature changed in 8.1:
-# declare 16 win {
-# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
-# }
-# declare 17 win {
-# char *TclpGetTZName(void)
-# }
-# new for 8.5.12+ Cygwin only
declare 17 win {
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
@@ -1150,42 +792,21 @@ declare 19 win {
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
-# new for 8.4.20+/8.5.12+
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
-# removed permanently for 8.4
-#declare 21 win {
-# void TclpAsyncMark(Tcl_AsyncHandler async)
-#}
-
-# Added in 8.1:
declare 22 win {
TclFile TclpCreateTempFile(const char *contents)
}
-# Removed in 8.6:
-#declare 23 win {
-# char *TclpGetTZName(int isdst)
-#}
declare 24 win {
char *TclWinNoBackslash(char *path)
}
-# replaced by generic TclGetPlatform
-#declare 25 win {
-# TclPlatformType *TclWinGetPlatform(void)
-#}
declare 26 win {
void TclWinSetInterfaces(int wide)
}
-
-# Added in Tcl 8.3.3 / 8.4
-
declare 27 win {
void TclWinFlushDirtyChannels(void)
}
-
-# Added in 8.4.2
-
declare 28 win {
void TclWinResetInterfaces(void)
}
@@ -1284,7 +905,7 @@ declare 22 {unix macosx} {
}
declare 29 {win unix} {
- int TclWinCPUID(unsigned int index, unsigned int *regs)
+ int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3fa9a11..31c7fcb 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -26,6 +26,47 @@
#undef ACCEPT_NAN
/*
+ * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3.
+ * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them
+ * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+
+ * releases. Perhaps Tcl 8.7 will add even better public interfaces
+ * supporting all the re-invocation mechanisms extensions like Itcl 3
+ * need. As an absolute last resort, folks who must make Itcl 3 work
+ * unchanged with Tcl 8.7 can remove this line to regain the migration
+ * support. Tcl 9 will no longer offer even that option.
+ */
+
+#define AVOID_HACKS_FOR_ITCL 1
+
+
+/*
+ * Used to tag functions that are only to be visible within the module being
+ * built and not outside it (where this is supported by the linker).
+ * Also used in the platform-specific *Port.h files.
+ */
+
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+#ifndef JOIN
+# define JOIN(a,b) JOIN1(a,b)
+# define JOIN1(a,b) a##b
+#endif
+
+#if defined(__cplusplus)
+# define TCL_UNUSED(T) T
+#elif defined(__GNUC__) && (__GNUC__ > 2)
+# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused))
+#else
+# define TCL_UNUSED(T) T JOIN(dummy, __LINE__)
+#endif
+
+/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
@@ -48,12 +89,7 @@
#else
#include <string.h>
#endif
-#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
- || defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC)
-#include <stddef.h>
-#else
-typedef int ptrdiff_t;
-#endif
+#include <locale.h>
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
@@ -82,47 +118,48 @@ typedef int ptrdiff_t;
#endif
/*
- * Used to tag functions that are only to be visible within the module being
- * built and not outside it (where this is supported by the linker).
- */
-
-#ifndef MODULE_SCOPE
-# ifdef __cplusplus
-# define MODULE_SCOPE extern "C"
-# else
-# define MODULE_SCOPE extern
-# endif
-#endif
-
-/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
*/
-#if !defined(INT2PTR) && !defined(PTR2INT)
-# if defined(HAVE_INTPTR_T) || defined(intptr_t)
-# define INT2PTR(p) ((void *)(intptr_t)(p))
-# define PTR2INT(p) ((int)(intptr_t)(p))
-# else
-# define INT2PTR(p) ((void *)(p))
-# define PTR2INT(p) ((int)(p))
-# endif
+#if !defined(INT2PTR)
+# define INT2PTR(p) ((void *)(ptrdiff_t)(p))
#endif
-#if !defined(UINT2PTR) && !defined(PTR2UINT)
-# if defined(HAVE_UINTPTR_T) || defined(uintptr_t)
-# define UINT2PTR(p) ((void *)(uintptr_t)(p))
-# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p))
-# else
-# define UINT2PTR(p) ((void *)(p))
-# define PTR2UINT(p) ((unsigned int)(p))
-# endif
+#if !defined(PTR2INT)
+# define PTR2INT(p) ((ptrdiff_t)(p))
+#endif
+#if !defined(UINT2PTR)
+# define UINT2PTR(p) ((void *)(size_t)(p))
+#endif
+#if !defined(PTR2UINT)
+# define PTR2UINT(p) ((size_t)(p))
#endif
#if defined(_WIN32) && defined(_MSC_VER)
# define vsnprintf _vsnprintf
#endif
+#if !defined(TCL_THREADS)
+# define TCL_THREADS 1
+#endif
+#if !TCL_THREADS
+# undef TCL_DECLARE_MUTEX
+# define TCL_DECLARE_MUTEX(name)
+# undef Tcl_MutexLock
+# define Tcl_MutexLock(mutexPtr)
+# undef Tcl_MutexUnlock
+# define Tcl_MutexUnlock(mutexPtr)
+# undef Tcl_MutexFinalize
+# define Tcl_MutexFinalize(mutexPtr)
+# undef Tcl_ConditionNotify
+# define Tcl_ConditionNotify(condPtr)
+# undef Tcl_ConditionWait
+# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+# undef Tcl_ConditionFinalize
+# define Tcl_ConditionFinalize(condPtr)
+#endif
+
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -147,13 +184,13 @@ typedef struct Tcl_ResolvedVarInfo {
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
- CONST84 char *name, int length, Tcl_Namespace *context,
+ const char *name, Tcl_Size length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
-typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
-typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
typedef struct Tcl_ResolverInfo {
@@ -235,7 +272,7 @@ typedef struct Namespace {
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
- ClientData clientData; /* An arbitrary value associated with this
+ void *clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
@@ -252,16 +289,16 @@ typedef struct Namespace {
* 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
+ unsigned long nsId; /* Unique id for the namespace. */
+ Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
- int activationCount; /* Number of "activations" or active call
+ Tcl_Size activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
* freed until activationCount becomes zero. */
- int refCount; /* Count of references by namespaceName
+ Tcl_Size refCount; /* Count of references by namespaceName
* objects. The namespace can't be freed until
* refCount becomes zero. */
Tcl_HashTable cmdTable; /* Contains all the commands currently
@@ -282,16 +319,16 @@ typedef struct Namespace {
* commands; however, no namespace qualifiers
* are allowed. NULL if no export patterns are
* registered. */
- int numExportPatterns; /* Number of export patterns currently
+ Tcl_Size numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
- int maxExportPatterns; /* Mumber of export patterns for which space
+ Tcl_Size maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
+ Tcl_Size cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
- int resolverEpoch; /* Incremented whenever (a) the name
+ Tcl_Size resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
@@ -318,7 +355,7 @@ typedef struct Namespace {
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
- int exportLookupEpoch; /* Incremented whenever a command is added to
+ Tcl_Size exportLookupEpoch; /* Incremented whenever a command is added to
* a namespace, removed from a namespace or
* the exports of a namespace are changed.
* Allows TIP#112-driven command lists to be
@@ -329,7 +366,7 @@ typedef struct Namespace {
Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
* resolution in this namespace fails. TIP
* 181. */
- int commandPathLength; /* The length of the explicit path. */
+ Tcl_Size commandPathLength; /* The length of the explicit path. */
NamespacePathEntry *commandPathArray;
/* The explicit path of the namespace as an
* array. */
@@ -367,21 +404,19 @@ struct NamespacePathEntry {
* Flags used to represent the status of a namespace:
*
* NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace but there are still active call frames on the Tcl
+ * namespace. There may still be active call frames on the Tcl
* stack that refer to the namespace. When the last call frame
- * referring to it has been popped, it's variables and command
- * will be destroyed and it will be marked "dead" (NS_DEAD). The
- * namespace can no longer be looked up by name.
+ * referring to it has been popped, its remaining variables and
+ * commands are destroyed and it is marked "dead" (NS_DEAD).
+ * NS_TEARDOWN -1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942].
* NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace and no call frames still refer to it. Its variables
- * and command have already been destroyed. This bit allows the
- * namespace resolution code to recognize that the namespace is
- * "deleted". When the last namespaceName object in any byte code
- * 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]
+ * namespace and no call frames still refer to it. It is no longer
+ * accessible by name. Its variables and commands have already
+ * been destroyed. When the last namespaceName object in any byte
+ * code 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_SUPPRESS_COMPILATION -
* Marks the commands in this namespace for not being compiled,
* forcing them to be looked up every time.
@@ -389,7 +424,8 @@ struct NamespacePathEntry {
#define NS_DYING 0x01
#define NS_DEAD 0x02
-#define NS_KILLED 0x04
+#define NS_TEARDOWN 0x04
+#define NS_KILLED 0x04 /* Same as NS_TEARDOWN (Deprecated) */
#define NS_SUPPRESS_COMPILATION 0x08
/*
@@ -419,7 +455,7 @@ typedef struct EnsembleConfig {
* 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
+ Tcl_Size 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
@@ -476,7 +512,7 @@ typedef struct EnsembleConfig {
* 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
+ Tcl_Size 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. */
@@ -506,7 +542,7 @@ typedef struct EnsembleConfig {
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
- ClientData clientData; /* Argument to pass to proc. */
+ void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
@@ -525,14 +561,14 @@ typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;
/* Procedure to call when operations given by
* flags are performed on command. */
- ClientData clientData; /* Argument to pass to proc. */
+ void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
- int refCount; /* Used to ensure this structure is not
+ Tcl_Size refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
@@ -605,7 +641,7 @@ typedef struct Var {
typedef struct VarInHash {
Var var;
- int refCount; /* Counts number of active uses of this
+ Tcl_Size refCount; /* Counts number of active uses of this
* variable: 1 for the entry in the hash
* table, 1 for each additional variable whose
* linkPtr points here, 1 for each nested
@@ -910,9 +946,9 @@ typedef struct CompiledLocal {
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
- int nameLength; /* The number of bytes in local variable's name.
+ Tcl_Size nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
- int frameIndex; /* Index in the array of compiler-assigned
+ Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
@@ -925,7 +961,7 @@ typedef struct CompiledLocal {
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
- * is marked by a unique ClientData tag during
+ * is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
@@ -944,7 +980,7 @@ typedef struct CompiledLocal {
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command is
* defined. */
- int refCount; /* Reference count: 1 if still present in
+ Tcl_Size refCount; /* Reference count: 1 if still present in
* command table plus 1 for each call to the
* procedure that is currently active. This
* structure can be freed when refCount
@@ -955,8 +991,8 @@ typedef struct Proc {
* procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
- int numArgs; /* Number of formal parameters. */
- int numCompiledLocals; /* Count of local variables recognized by the
+ Tcl_Size numArgs; /* Number of formal parameters. */
+ Tcl_Size numCompiledLocals; /* Count of local variables recognized by the
* compiler including arguments and
* temporaries. */
CompiledLocal *firstLocalPtr;
@@ -983,10 +1019,10 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
*/
typedef struct Trace {
- int level; /* Only trace commands at nesting level less
+ Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
+ void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
@@ -1038,7 +1074,7 @@ typedef struct ActiveInterpTrace {
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
- ClientData clientData; /* Value to pass to proc. */
+ void *clientData; /* Value to pass to proc. */
} AssocData;
/*
@@ -1061,8 +1097,8 @@ typedef struct AssocData {
*/
typedef struct LocalCache {
- int refCount;
- int numVars;
+ Tcl_Size refCount;
+ Tcl_Size numVars;
Tcl_Obj *varName0;
} LocalCache;
@@ -1082,7 +1118,7 @@ typedef struct CallFrame {
* If FRAME_IS_PROC is set, the frame was
* pushed to execute a Tcl procedure and may
* have local vars. */
- int objc; /* This and objv below describe the arguments
+ Tcl_Size objc; /* This and objv below describe the arguments
* for this procedure call. */
Tcl_Obj *const *objv; /* Array of argument objects. */
struct CallFrame *callerPtr;
@@ -1096,7 +1132,7 @@ typedef struct CallFrame {
* callerPtr unless an "uplevel" command or
* something equivalent was active in the
* caller). */
- int level; /* Level of this procedure, for "uplevel"
+ Tcl_Size level; /* Level of this procedure, for "uplevel"
* purposes (i.e. corresponds to nesting of
* callerVarPtr's, not callerPtr's). 1 for
* outermost procedure, 0 for top-level. */
@@ -1110,13 +1146,13 @@ typedef struct CallFrame {
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
- int numCompiledLocals; /* Count of local variables recognized by the
- * compiler including arguments. */
+ Tcl_Size numCompiledLocals; /* Count of local variables recognized
+ * by the compiler including arguments. */
Var *compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
- ClientData clientData; /* Pointer to some context that is used by
+ void *clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
* sets it, and it should only ever be set by
@@ -1140,6 +1176,10 @@ typedef struct CallFrame {
* field contains an Object reference that has
* been confirmed to refer to a class. Part of
* TIP#257. */
+#define FRAME_IS_PRIVATE_DEFINE 0x10
+ /* Marks this frame as being used for private
+ * declarations with [oo::define]. Usually
+ * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */
/*
* TIP #280
@@ -1168,7 +1208,7 @@ typedef struct CmdFrame {
int level; /* Number of frames in stack, prevent O(n)
* scan of list. */
int *line; /* Lines the words of the command start on. */
- int nline;
+ Tcl_Size nline;
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
@@ -1212,7 +1252,7 @@ typedef struct CmdFrame {
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
- int len; /* ... and its length. */
+ Tcl_Size len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
@@ -1222,16 +1262,16 @@ typedef struct CmdFrame {
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
- int word; /* Index of the word in the command. */
- int refCount; /* Number of times the word is on the
+ Tcl_Size word; /* Index of the word in the command. */
+ Tcl_Size refCount; /* Number of times the word is on the
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
- int pc; /* Instruction pointer of a command in
+ Tcl_Size pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
- int word; /* Index of word in
+ Tcl_Size 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
@@ -1260,7 +1300,7 @@ typedef struct CFWordBC {
#define CLL_END (-1)
typedef struct ContLineLoc {
- int num; /* Number of entries in loc, not counting the
+ Tcl_Size num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
int loc[TCLFLEXARRAY];/* Table of locations, as character offsets.
* The table is allocated as part of the
@@ -1300,17 +1340,17 @@ typedef struct ContLineLoc {
* by [info frame]. Contains a sub-structure for each extra field.
*/
-typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
+typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);
typedef struct {
const char *name; /* Name of this field. */
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
+ void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
- int length; /* Length of array. */
+ Tcl_Size length; /* Length of array. */
ExtraFrameInfoField fields[2];
/* Really as long as necessary, but this is
* long enough for nearly anything. */
@@ -1351,7 +1391,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
*/
#define TCL_TSD_INIT(keyPtr) \
- (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
/*
*----------------------------------------------------------------
@@ -1388,7 +1428,9 @@ struct CompileEnv;
* sake of old code only.
*/
-#define TCL_OUT_LINE_COMPILE TCL_ERROR
+#ifndef TCL_NO_DEPRECATED
+# define TCL_OUT_LINE_COMPILE TCL_ERROR
+#endif
typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
@@ -1399,7 +1441,7 @@ typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
*/
typedef int (CompileHookProc)(Tcl_Interp *interp,
- struct CompileEnv *compEnvPtr, ClientData clientData);
+ struct CompileEnv *compEnvPtr, void *clientData);
/*
* The data structure for a (linked list of) execution stacks.
@@ -1441,13 +1483,18 @@ typedef struct CoroutineData {
CorContext running;
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
void *stackLevel;
- int auxNumLevels; /* While the coroutine is running the
+ Tcl_Size 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" */
+ Tcl_Size nargs; /* Number of args required for resuming this
+ * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1"
+ * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */
+ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in
+ * order to reset splice point in
+ * TclNRCoroutineActivateCallback if the
+ * coroutine is busy.
+ */
} CoroutineData;
typedef struct ExecEnv {
@@ -1486,11 +1533,11 @@ typedef struct LiteralEntry {
* NULL if end of chain. */
Tcl_Obj *objPtr; /* Points to Tcl object that holds the
* literal's bytes and length. */
- int refCount; /* If in an interpreter's global literal
+ Tcl_Size refCount; /* If in an interpreter's global literal
* table, the number of ByteCode structures
* that share the literal object; the literal
* entry can be freed when refCount drops to
- * 0. If in a local literal table, -1. */
+ * 0. If in a local literal table, TCL_INDEX_NONE. */
Namespace *nsPtr; /* Namespace in which this literal is used. We
* try to avoid sharing literal non-FQ command
* names among different namespaces to reduce
@@ -1504,13 +1551,13 @@ typedef struct LiteralTable {
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
- int numBuckets; /* Total number of buckets allocated at
+ TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at
* **buckets. */
- int numEntries; /* Total number of entries present in
+ TCL_HASH_TYPE numEntries; /* Total number of entries present in
* table. */
- int rebuildSize; /* Enlarge table when numEntries gets to be
+ TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
- int mask; /* Mask value used in hashing function. */
+ TCL_HASH_TYPE mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
@@ -1521,10 +1568,10 @@ typedef struct LiteralTable {
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
- long numExecutions; /* Number of ByteCodes executed. */
- long numCompilations; /* Number of ByteCodes created. */
- long numByteCodesFreed; /* Number of ByteCodes destroyed. */
- long instructionCount[256]; /* Number of times each instruction was
+ size_t numExecutions; /* Number of ByteCodes executed. */
+ size_t numCompilations; /* Number of ByteCodes created. */
+ size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */
+ size_t instructionCount[256]; /* Number of times each instruction was
* executed. */
double totalSrcBytes; /* Total source bytes ever compiled. */
@@ -1532,10 +1579,10 @@ typedef struct ByteCodeStats {
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
- long srcCount[32]; /* Source size distribution: # of srcs of
+ size_t srcCount[32]; /* Source size distribution: # of srcs of
* size [2**(n-1)..2**n), n in [0..32). */
- long byteCodeCount[32]; /* ByteCode size distribution. */
- long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
+ size_t byteCodeCount[32]; /* ByteCode size distribution. */
+ size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
double currentLitBytes; /* Current literal bytes. */
@@ -1543,11 +1590,11 @@ typedef struct ByteCodeStats {
double currentAuxBytes; /* Current auxiliary information bytes. */
double currentCmdMapBytes; /* Current src<->code map bytes. */
- long numLiteralsCreated; /* Total literal objects ever compiled. */
+ size_t numLiteralsCreated; /* Total literal objects ever compiled. */
double totalLitStringBytes; /* Total string bytes in all literals. */
double currentLitStringBytes;
/* String bytes in current literals. */
- long literalCount[32]; /* Distribution of literal string sizes. */
+ size_t literalCount[32]; /* Distribution of literal string sizes. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */
@@ -1562,7 +1609,7 @@ typedef struct {
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. */
+ void *clientData; /* Any clientData to give the command. */
int unsafe; /* Whether this command is to be hidden by
* default in a safe interpreter. */
} EnsembleImplMap;
@@ -1628,24 +1675,24 @@ typedef struct Command {
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
- int refCount; /* 1 if in command hashtable plus 1 for each
+ Tcl_Size refCount; /* 1 if in command hashtable plus 1 for each
* reference from a CmdName Tcl object
* representing a command's name in a ByteCode
* instruction sequence. This structure can be
* freed when refCount becomes zero. */
- int cmdEpoch; /* Incremented to invalidate any references
+ Tcl_Size cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
- ClientData objClientData; /* Arbitrary value passed to object proc. */
+ void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
- ClientData clientData; /* Arbitrary value passed to string proc. */
+ void *clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command to,
* e.g., free all client data. */
- ClientData deleteData; /* Arbitrary value passed to deleteProc. */
+ void *deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
@@ -1663,18 +1710,18 @@ typedef struct Command {
/*
* Flag bits for commands.
*
- * CMD_IS_DELETED - Means that the command is in the process of
+ * CMD_DYING - If 1 the command is in the process of
* being deleted (its deleteProc is currently
* executing). Other attempts to delete the
* command should be ignored.
- * CMD_TRACE_ACTIVE - 1 means that trace processing is currently
+ * CMD_TRACE_ACTIVE - If 1 the trace processing is currently
* underway for a rename/delete change. See the
* two flags below for which is currently being
* processed.
- * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
+ * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
- * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that
* can handle expansion (provided it is not the
* first word).
* TCL_TRACE_RENAME - A rename trace is in progress. Further
@@ -1684,7 +1731,10 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x01
+#define CMD_DYING 0x01
+#ifndef TCL_NO_DEPRECATED
+# define CMD_IS_DELETED 0x01 /* Same as CMD_DYING */
+#endif
#define CMD_TRACE_ACTIVE 0x02
#define CMD_HAS_EXEC_TRACES 0x04
#define CMD_COMPILES_EXPANDED 0x08
@@ -1754,7 +1804,7 @@ 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. */
+ size_t numObjects; /* Number of objects for thread. */
} AllocCache;
/*
@@ -1812,7 +1862,7 @@ typedef struct Interp {
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
- ClientData interpInfo; /* Information used by tclInterp.c to keep
+ void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
union {
@@ -1823,18 +1873,17 @@ typedef struct Interp {
* contains one optimizer, which can be
* selectively overridden by extensions. */
} extra;
-
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
- int numLevels; /* Keeps track of how many nested calls to
+ Tcl_Size numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
* interpreter. It's used to delay deletion of
* the table until all Tcl_Eval invocations
* are completed. */
- int maxNestingDepth; /* If numLevels exceeds this value then Tcl
+ Tcl_Size maxNestingDepth; /* If numLevels exceeds this value then Tcl
* assumes that infinite recursion has
* occurred and it generates an error. */
CallFrame *framePtr; /* Points to top-most in stack of all nested
@@ -1857,6 +1906,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
+#if !defined(TCL_NO_DEPRECATED)
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1864,6 +1914,11 @@ typedef struct Interp {
* partialResult. */
int appendUsed; /* Number of non-null bytes currently stored
* at partialResult. */
+#else
+ char *appendResultDontUse;
+ int appendAvlDontUse;
+ int appendUsedDontUse;
+#endif
/*
* Information about packages. Used only in tclPkg.c.
@@ -1881,7 +1936,7 @@ typedef struct Interp {
* Miscellaneous information:
*/
- int cmdCount; /* Total number of times a command procedure
+ Tcl_Size cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
@@ -1893,7 +1948,7 @@ typedef struct Interp {
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
- int compileEpoch; /* Holds the current "compilation epoch" for
+ Tcl_Size compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
@@ -1925,8 +1980,12 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
- char resultSpace[TCL_RESULT_SIZE+1];
+#if !defined(TCL_NO_DEPRECATED)
+ char resultSpace[TCL_DSTRING_STATIC_SIZE+1];
/* Static space holding small results. */
+#else
+ char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
+#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
@@ -1939,7 +1998,7 @@ typedef struct Interp {
/* First in list of active traces for interp,
* or NULL if no active traces. */
- int tracesForbiddingInline; /* Count of traces (in the list headed by
+ Tcl_Size tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation. */
@@ -1969,7 +2028,7 @@ typedef struct Interp {
* as flag values the same as the 'active'
* field. */
- int cmdCount; /* Limit for how many commands to execute in
+ Tcl_Size cmdCount; /* Limit for how many commands to execute in
* the interpreter. */
LimitHandler *cmdHandlers;
/* Handlers to execute when the limit is
@@ -2005,9 +2064,9 @@ typedef struct Interp {
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
- int numRemovedObjs; /* How many arguments have been stripped off
+ Tcl_Size numRemovedObjs; /* How many arguments have been stripped off
* because of ensemble processing. */
- int numInsertedObjs; /* How many of the current arguments were
+ Tcl_Size numInsertedObjs; /* How many of the current arguments were
* inserted by an ensemble. */
} ensembleRewrite;
@@ -2302,22 +2361,41 @@ typedef struct Interp {
#endif
/*
- * This macro is used to determine the offset needed to safely allocate any
+ * TCL_ALIGN is used to determine the offset needed to safely allocate any
* data structure in memory. Given a starting offset or size, it "rounds up"
- * or "aligns" the offset to the next 8-byte boundary so that any data
- * structure can be placed at the resulting offset without fear of an
- * alignment error.
+ * or "aligns" the offset to the next aligned (typically 8-byte) boundary so
+ * that any data structure can be placed at the resulting offset without fear
+ * of an alignment error. Note this is clamped to a minimum of 8 for API
+ * compatibility.
*
* WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the
- * wrong result on platforms that allocate addresses that are divisible by 4
- * or 2. Only use it for offsets or sizes.
+ * wrong result on platforms that allocate addresses that are divisible by a
+ * non-trivial factor of this alignment. Only use it for offsets or sizes.
*
* This macro is only used by tclCompile.c in the core (Bug 926445). It
* however not be made file static, as extensions that touch bytecodes
* (notably tbcload) require it.
*/
-#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
+struct TclMaxAlignment {
+ char unalign[8];
+ union {
+ long long maxAlignLongLong;
+ double maxAlignDouble;
+ void *maxAlignPointer;
+ } aligned;
+};
+#define TCL_ALIGN_BYTES \
+ offsetof(struct TclMaxAlignment, aligned)
+#define TCL_ALIGN(x) \
+ (((x) + (TCL_ALIGN_BYTES - 1)) & ~(TCL_ALIGN_BYTES - 1))
+
+/*
+ * A common panic alert when memory allocation fails.
+ */
+
+#define TclOOM(ptr, size) \
+ ((size) && ((ptr)||(Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", (size_t)(size)),1)))
/*
* The following enum values are used to specify the runtime platform setting
@@ -2361,67 +2439,201 @@ typedef enum TclEolTranslation {
#define TCL_INVOKE_NO_UNKNOWN (1<<1)
#define TCL_INVOKE_NO_TRACEBACK (1<<2)
+#if TCL_MAJOR_VERSION > 8
/*
- * The structure used as the internal representation of Tcl list objects. This
- * struct is grown (reallocated and copied) as necessary to hold all the
- * list's element pointers. The struct might contain more slots than currently
- * used to hold all element pointers. This is done to make append operations
- * faster.
+ * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed
+ * between values of the Tcl_Size type so limit the range to signed
*/
+# define ListSizeT_MAX ((Tcl_Size)PTRDIFF_MAX)
+#else
+# define ListSizeT_MAX INT_MAX
+#endif
-typedef struct List {
- int refCount;
- int maxElemCount; /* Total number of element array slots. */
- int elemCount; /* Current number of list elements. */
- int canonicalFlag; /* Set if the string representation was
- * derived from the list representation. May
- * be ignored if there is no string rep at
- * all.*/
- Tcl_Obj *elements; /* First list element; the struct is grown to
- * accommodate all elements. */
-} List;
-
-#define LIST_MAX \
- (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
-#define LIST_SIZE(numElems) \
- (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
+/*
+ * ListStore --
+ *
+ * A Tcl list's internal representation is defined through three structures.
+ *
+ * A ListStore struct is a structure that includes a variable size array that
+ * serves as storage for a Tcl list. A contiguous sequence of slots in the
+ * array, the "in-use" area, holds valid pointers to Tcl_Obj values that
+ * belong to one or more Tcl lists. The unused slots before and after these
+ * are free slots that may be used to prepend and append without having to
+ * reallocate the struct. The ListStore may be shared amongst multiple lists
+ * and reference counted.
+ *
+ * A ListSpan struct defines a sequence of slots within a ListStore. This sequence
+ * always lies within the "in-use" area of the ListStore. Like ListStore, the
+ * structure may be shared among multiple lists and is reference counted.
+ *
+ * A ListRep struct holds the internal representation of a Tcl list as stored
+ * in a Tcl_Obj. It is composed of a ListStore and a ListSpan that together
+ * define the content of the list. The ListSpan specifies the range of slots
+ * within the ListStore that hold elements for this list. The ListSpan is
+ * optional in which case the list includes all the "in-use" slots of the
+ * ListStore.
+ *
+ */
+typedef struct ListStore {
+ Tcl_Size firstUsed; /* Index of first slot in use within slots[] */
+ Tcl_Size numUsed; /* Number of slots in use (starting firstUsed) */
+ Tcl_Size numAllocated; /* Total number of slots[] array slots. */
+ size_t refCount; /* Number of references to this instance */
+ int flags; /* LISTSTORE_* flags */
+ Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */
+} ListStore;
+
+#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
+ store have their string representation
+ derived from the list representation */
+
+/* Max number of elements that can be contained in a list */
+#define LIST_MAX \
+ ((Tcl_Size)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \
+ / sizeof(Tcl_Obj *)))
+/* Memory size needed for a ListStore to hold numSlots_ elements */
+#define LIST_SIZE(numSlots_) \
+ ((int)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))))
+
+/*
+ * ListSpan --
+ * See comments above for ListStore
+ */
+typedef struct ListSpan {
+ Tcl_Size spanStart; /* Starting index of the span */
+ Tcl_Size spanLength; /* Number of elements in the span */
+ size_t refCount; /* Count of references to this span record */
+} ListSpan;
+#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
+#define LIST_SPAN_THRESHOLD 101
+#endif
/*
- * Macro used to get the elements of a list object.
+ * ListRep --
+ * See comments above for ListStore
*/
+typedef struct ListRep {
+ ListStore *storePtr;/* element array shared amongst different lists */
+ ListSpan *spanPtr; /* If not NULL, the span holds the range of slots
+ within *storePtr that contain this list elements. */
+} ListRep;
-#define ListRepPtr(listPtr) \
- ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
+/*
+ * Macros used to get access list internal representations.
+ *
+ * Naming conventions:
+ * ListRep* - expect a pointer to a valid ListRep
+ * ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to
+ * be a list (tclListType). Will crash otherwise.
+ * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
+ * be tclListType. These will convert as needed and return error if
+ * conversion not possible.
+ */
+
+/* Returns the starting slot for this listRep in the contained ListStore */
+#define ListRepStart(listRepPtr_) \
+ ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \
+ : (listRepPtr_)->storePtr->firstUsed)
+
+/* Returns the number of elements in this listRep */
+#define ListRepLength(listRepPtr_) \
+ ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \
+ : (listRepPtr_)->storePtr->numUsed)
+
+/* Returns a pointer to the first slot containing this ListRep elements */
+#define ListRepElementsBase(listRepPtr_) \
+ (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)])
+
+/* Stores the number of elements and base address of the element array */
+#define ListRepElements(listRepPtr_, objc_, objv_) \
+ (((objv_) = ListRepElementsBase(listRepPtr_)), \
+ ((objc_) = ListRepLength(listRepPtr_)))
+
+/* Returns 1/0 whether the ListRep's ListStore is shared. */
+#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1)
+
+/* Returns a pointer to the ListStore component */
+#define ListObjStorePtr(listObj_) \
+ ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1))
+
+/* Returns a pointer to the ListSpan component */
+#define ListObjSpanPtr(listObj_) \
+ ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2))
+
+/* Returns the ListRep internal representaton in a Tcl_Obj */
+#define ListObjGetRep(listObj_, listRepPtr_) \
+ do { \
+ (listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \
+ (listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \
+ } while (0)
-/* Not used any more */
-#define ListSetIntRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
+/* Returns the length of the list */
+#define ListObjLength(listObj_, len_) \
+ ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \
+ : ListObjStorePtr(listObj_)->numUsed)
-#define ListObjGetElements(listPtr, objc, objv) \
- ((objv) = &(ListRepPtr(listPtr)->elements), \
- (objc) = ListRepPtr(listPtr)->elemCount)
+/* Returns the starting slot index of this list's elements in the ListStore */
+#define ListObjStart(listObj_) \
+ (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \
+ : ListObjStorePtr(listObj_)->firstUsed)
-#define ListObjLength(listPtr, len) \
- ((len) = ListRepPtr(listPtr)->elemCount)
+/* Stores the element count and base address of this list's elements */
+#define ListObjGetElements(listObj_, objc_, objv_) \
+ (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
+ (ListObjLength(listObj_, (objc_))))
+
+/*
+ * Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
+ * is shared. Note by intent this only checks for sharing of ListStore,
+ * not spans.
+ */
+#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1)
-#define ListObjIsCanonical(listPtr) \
- (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag)
+/*
+ * Certain commands like concat are optimized if an existing string
+ * representation of a list object is known to be in canonical format (i.e.
+ * generated from the list representation). There are three conditions when
+ * this will be the case:
+ * (1) No string representation exists which means it will obviously have
+ * to be generated from the list representation when needed
+ * (2) The ListStore flags is marked canonical. This is done at the time
+ * the string representation is generated from the list IF the list
+ * representation does not have a span (see comments in UpdateStringOfList).
+ * (3) The list representation does not have a span component. This is
+ * because list Tcl_Obj's with spans are always created from existing lists
+ * and never from strings (see SetListFromAny) and thus their string
+ * representation will always be canonical.
+ */
+#define ListObjIsCanonical(listObj_) \
+ (((listObj_)->bytes == NULL) \
+ || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
+ || ListObjSpanPtr(listObj_) != NULL)
-#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
- : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+/*
+ * Converts the Tcl_Obj to a list if it isn't one and stores the element
+ * count and base address of this list's elements in objcPtr_ and objvPtr_.
+ * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
+ * converted to a list.
+ */
+#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \
+ (((listObj_)->typePtr == &tclListType) \
+ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
+ TCL_OK) \
+ : Tcl_ListObjGetElements( \
+ (interp_), (listObj_), (objcPtr_), (objvPtr_)))
-#define TclListObjLength(interp, listPtr, lenPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
- : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+/*
+ * Converts the Tcl_Obj to a list if it isn't one and stores the element
+ * count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
+ * Tcl_Obj cannot be converted to a list.
+ */
+#define TclListObjLengthM(interp_, listObj_, lenPtr_) \
+ (((listObj_)->typePtr == &tclListType) \
+ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
+ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
-#define TclListObjIsCanonical(listPtr) \
- (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+#define TclListObjIsCanonical(listObj_) \
+ (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
@@ -2432,40 +2644,45 @@ typedef struct List {
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
- * Macros providing a faster path to integers: Tcl_GetLongFromObj,
- * Tcl_GetIntFromObj and TclGetIntForIndex.
+ * Macros providing a faster path to booleans and integers:
+ * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
+ * and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
+#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
+ : ((objPtr)->typePtr == &tclBooleanType) \
+ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
+ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
+
+#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
-
-#if (LONG_MAX == INT_MAX)
-#define TclGetIntFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
-#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
#else
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
+ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+#endif
+
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \
- && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
+ ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- (((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= INT_MIN \
- && (objPtr)->internalRep.longValue <= INT_MAX) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
-#endif
+ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
+ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \
+ ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
@@ -2475,21 +2692,11 @@ typedef struct List {
* Tcl_WideInt *wideIntPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
- Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
-#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
- (((objPtr)->typePtr == &tclWideIntType) \
- ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
- ((objPtr)->typePtr == &tclIntType) \
- ? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
+ ? (*(wideIntPtr) = \
+ ((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Flag values for TclTraceDictPath().
@@ -2532,7 +2739,7 @@ typedef struct List {
*/
#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2)
-typedef ClientData (TclFSGetCwdProc2)(ClientData clientData);
+typedef void *(TclFSGetCwdProc2)(void *clientData);
typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
@@ -2566,10 +2773,12 @@ typedef struct TclFile_ *TclFile;
* combination of the following values:
*/
-#define TCL_GLOBMODE_NO_COMPLAIN 1
-#define TCL_GLOBMODE_JOIN 2
-#define TCL_GLOBMODE_DIR 4
-#define TCL_GLOBMODE_TAILS 8
+#ifndef TCL_NO_DEPRECATED
+# define TCL_GLOBMODE_NO_COMPLAIN 1
+# define TCL_GLOBMODE_JOIN 2
+# define TCL_GLOBMODE_DIR 4
+# define TCL_GLOBMODE_TAILS 8
+#endif
typedef enum Tcl_PathPart {
TCL_PATH_DIRNAME,
@@ -2595,8 +2804,10 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
*----------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;
+#endif
/*
*----------------------------------------------------------------
@@ -2604,7 +2815,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
-typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2616,9 +2827,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
*/
typedef struct ProcessGlobalValue {
- int epoch; /* Epoch counter to detect changes in the
+ Tcl_Size epoch; /* Epoch counter to detect changes in the
* global value. */
- int numBytes; /* Length of the global string. */
+ TCL_HASH_TYPE numBytes; /* Length of the global string. */
char *value; /* The global string value. */
Tcl_Encoding encoding; /* system encoding when global string was
* initialized. */
@@ -2654,18 +2865,8 @@ typedef struct ProcessGlobalValue {
/* Reject leading/trailing whitespace. */
#define TCL_PARSE_BINARY_ONLY 64
/* Parse binary even without prefix. */
-
-/*
- *----------------------------------------------------------------------
- * Type values TclGetNumberFromObj
- *----------------------------------------------------------------------
- */
-
-#define TCL_NUMBER_LONG 1
-#define TCL_NUMBER_WIDE 2
-#define TCL_NUMBER_BIG 3
-#define TCL_NUMBER_DOUBLE 4
-#define TCL_NUMBER_NAN 5
+#define TCL_PARSE_NO_UNDERSCORE 128
+ /* Reject underscore digit separator */
/*
*----------------------------------------------------------------
@@ -2677,7 +2878,6 @@ MODULE_SCOPE char *tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
-MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks;
MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
@@ -2688,7 +2888,7 @@ MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr;
MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr;
-MODULE_SCOPE ClientData tclTimeClientData;
+MODULE_SCOPE void *tclTimeClientData;
/*
* Variables denoting the Tcl object types defined in the core.
@@ -2699,17 +2899,14 @@ 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 tclArithSeriesType;
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 tclUniCharStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
-#ifndef TCL_WIDE_INT_IS_LONG
-MODULE_SCOPE const Tcl_ObjType tclWideIntType;
-#endif
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
MODULE_SCOPE Tcl_ObjType tclCmdNameType;
@@ -2730,10 +2927,10 @@ MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
MODULE_SCOPE Tcl_Obj * tclFreeObjList;
#ifdef TCL_COMPILE_STATS
-MODULE_SCOPE long tclObjsAlloced;
-MODULE_SCOPE long tclObjsFreed;
+MODULE_SCOPE size_t tclObjsAlloced;
+MODULE_SCOPE size_t tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
-MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
+MODULE_SCOPE size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */
/*
@@ -2742,7 +2939,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
* shared by all new objects allocated by Tcl_NewObj.
*/
-MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
enum CheckEmptyStringResult {
@@ -2805,7 +3001,7 @@ typedef struct ForIterData {
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 */
+ Tcl_Size word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
@@ -2815,7 +3011,7 @@ typedef struct ForIterData {
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
+ void *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
@@ -2829,29 +3025,19 @@ struct Tcl_LoadHandle_ {
/* Flags for conversion of doubles to digit strings */
-#define TCL_DD_SHORTEST 0x4
- /* Use the shortest possible string */
-#define TCL_DD_STEELE 0x5
- /* Use the original Steele&White algorithm */
#define TCL_DD_E_FORMAT 0x2
/* Use a fixed-length string of digits,
* suitable for E format*/
#define TCL_DD_F_FORMAT 0x3
/* Use a fixed number of digits after the
* decimal point, suitable for F format */
-
-#define TCL_DD_SHORTEN_FLAG 0x4
- /* Allow return of a shorter digit string
- * if it converts losslessly */
+#define TCL_DD_SHORTEST 0x4
+ /* Use the shortest possible string */
#define TCL_DD_NO_QUICK 0x8
/* Debug flag: forbid quick FP conversion */
#define TCL_DD_CONVERSION_TYPE_MASK 0x3
/* Mask to isolate the conversion type */
-#define TCL_DD_STEELE0 0x1
- /* 'Steele&White' after masking */
-#define TCL_DD_SHORTEST0 0x0
- /* 'Shortest possible' after masking */
/*
*----------------------------------------------------------------
@@ -2878,11 +3064,14 @@ 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 double TclBignumToDouble(const mp_int *bignum);
+MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId,
+ void *clientData, int *flagPtr, int value);
+MODULE_SCOPE void TclAsyncMarkFromNotifier(void);
+MODULE_SCOPE double TclBignumToDouble(const void *bignum);
MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
int strLen, const unsigned char *pattern,
int ptnLen, int flags);
-MODULE_SCOPE double TclCeil(const mp_int *a);
+MODULE_SCOPE double TclCeil(const void *a);
MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
@@ -2894,6 +3083,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
@@ -2903,25 +3094,20 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
-MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
- Tcl_Interp *interp,
- const char *cmdName,
- Tcl_Namespace *nsPtr,
- Tcl_ObjCmdProc *proc,
- ClientData clientData,
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
+ const char *cmdName, Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc);
-MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *nameNamespacePtr,
- Tcl_Namespace *ensembleNamespacePtr,
- int flags);
+MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
+ const char *name, Tcl_Namespace *nameNamespacePtr,
+ Tcl_Namespace *ensembleNamespacePtr, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
const char **elementPtr, const char **nextPtr,
int *sizePtr, int *literalPtr);
-/* TIP #280 - Modified token based evulation, with line information. */
+/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
int *clNextOuter, const char *outerScript);
@@ -2932,22 +3118,23 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileTildeExpandCmd;
MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
Tcl_Obj *objPtr);
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
-MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
-MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr);
-
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -2965,23 +3152,19 @@ MODULE_SCOPE void TclFinalizeNotifier(void);
MODULE_SCOPE void TclFinalizeObjects(void);
MODULE_SCOPE void TclFinalizePreserve(void);
MODULE_SCOPE void TclFinalizeSynchronization(void);
+MODULE_SCOPE void TclInitThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAllocThread(void);
MODULE_SCOPE void TclFinalizeThreadData(int quick);
MODULE_SCOPE void TclFinalizeThreadObjects(void);
-MODULE_SCOPE double TclFloor(const mp_int *a);
+MODULE_SCOPE double TclFloor(const void *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
const char *attributeName, int *indexPtr);
-MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
- Tcl_Interp *interp,
- const char *cmdName,
- Tcl_Namespace *nsPtr,
- Tcl_ObjCmdProc *proc,
- Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
- Tcl_CmdDeleteProc *deleteProc);
-
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
+ const char *cmdName, Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
+ void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
@@ -2993,9 +3176,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp,
MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr);
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);
+MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
const char *modeString, int *seekFlagPtr,
int *binaryPtr);
@@ -3003,25 +3185,22 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
- unsigned int *sizePtr);
-MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
- Tcl_Obj *unquotedPrefix, int globFlags,
- Tcl_GlobTypeData *types);
+ TCL_HASH_TYPE *sizePtr);
+MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp,
+ const char *targetName,
+ const char *packageName);
+MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
+ Tcl_WideInt *);
MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr);
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_ObjCmdProc TclInfoExistsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd;
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[]);
-MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd;
MODULE_SCOPE void TclInitAlloc(void);
MODULE_SCOPE void TclInitDbCkalloc(void);
MODULE_SCOPE void TclInitDoubleConversion(void);
@@ -3033,11 +3212,17 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE const char *TclInitSubsystems(void);
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
+MODULE_SCOPE int TclIsDigitProc(int byte);
MODULE_SCOPE int TclIsBareword(int byte);
MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[],
int forceRelative);
+MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user,
+ const char *subPath, Tcl_DString *dsPtr);
+MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user);
+MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp,
+ Tcl_Obj *pathObj);
+MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj);
MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp,
@@ -3048,6 +3233,11 @@ 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 TclListObjAppendElements(Tcl_Interp *interp,
+ Tcl_Obj *toObj, int elemCount,
+ Tcl_Obj *const elemObjv[]);
+MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx,
+ int toIdx);
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,
@@ -3055,6 +3245,7 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
const EnsembleImplMap map[]);
+MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes,
const char **endPtr);
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
@@ -3063,7 +3254,6 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int TclNokia770Doubles(void);
MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
-MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const char *operation,
@@ -3075,6 +3265,8 @@ MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
MODULE_SCOPE int TclParseBackslash(const char *src,
int numBytes, int *readPtr, char *dst);
+MODULE_SCOPE int TclParseHex(const char *src, int numBytes,
+ int *resultPtr);
MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *expected, const char *bytes,
int numBytes, const char **endPtrPtr, int flags);
@@ -3085,25 +3277,41 @@ MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
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 * TclpTempFileNameForLibrary(Tcl_Interp *interp,
+ Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
int len);
+MODULE_SCOPE void TclpAlertNotifier(void *clientData);
+MODULE_SCOPE void *TclpNotifierData(void);
+MODULE_SCOPE void TclpServiceModeHook(int mode);
+MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr);
+MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr);
+MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask,
+ Tcl_FileProc *proc, void *clientData);
MODULE_SCOPE int TclpDeleteFile(const void *path);
+MODULE_SCOPE void TclpDeleteFileHandler(int fd);
MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr);
MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
+MODULE_SCOPE void TclpFinalizeNotifier(void *clientData);
MODULE_SCOPE void TclpFinalizePipes(void);
MODULE_SCOPE void TclpFinalizeSockets(void);
+#ifdef _WIN32
+MODULE_SCOPE void TclInitSockets(void);
+#else
+#define TclInitSockets() /* do nothing */
+#endif
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, void *clientData,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
- int *lengthPtr, Tcl_Encoding *encodingPtr);
+ TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void TclpInitLock(void);
+MODULE_SCOPE void *TclpInitNotifier(void);
MODULE_SCOPE void TclpInitPlatform(void);
MODULE_SCOPE void TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void);
@@ -3122,7 +3330,7 @@ MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp,
MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp,
Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
const char *pattern, Tcl_GlobTypeData *types);
-MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData);
+MODULE_SCOPE void *TclpGetNativeCwd(void *clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
int linkType);
@@ -3130,6 +3338,9 @@ 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 void TclPkgFileSeen(Tcl_Interp *interp,
+ const char *fileName);
+MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
@@ -3138,7 +3349,7 @@ MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
void *data);
-MODULE_SCOPE void TclpThreadExit(int status);
+MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
@@ -3146,13 +3357,14 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
int *quantifiersFoundPtr);
-MODULE_SCOPE unsigned int TclScanElement(const char *string, int length,
+MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, int length,
char *flagPtr);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumInternalRep(Tcl_Obj *objPtr,
- mp_int *bignumValue);
-MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+ void *bignumValue);
+MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
@@ -3164,17 +3376,16 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
-
typedef int (*memCmpFn_t)(const void*, const void*, size_t);
-MODULE_SCOPE int TclStringCmp (Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
+MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
int checkEq, int nocase, int reqlength);
-MODULE_SCOPE int TclStringCmpOpts (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
- int *nocase, int *reqlength);
+MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int *nocase,
+ int *reqlength);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
-MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, int line,
struct CompileEnv *envPtr);
@@ -3192,26 +3403,23 @@ 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 const char*TclGetCommandTypeName(Tcl_Command command);
+MODULE_SCOPE void TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr);
+MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
-MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
-MODULE_SCOPE int TclUCS4ToUtf(int, char *);
-MODULE_SCOPE int TclUCS4ToLower(int ch);
-#if TCL_UTF_MAX == 4
- MODULE_SCOPE int TclGetUCS4(Tcl_Obj *, int);
- MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
-#else
-# define TclGetUCS4 Tcl_GetUniChar
+MODULE_SCOPE int TclUtfCount(int ch);
+#if TCL_UTF_MAX > 3
+# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
+# define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
+#else
+ MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
+ MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
+ MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *);
#endif
-
-/*
- * Bytes F0-F4 are start-bytes for 4-byte sequences.
- * Byte 0xED can be the start-byte of an upper surrogate. In that case,
- * TclUtfToUCS4() might read the lower surrogate following it too.
- */
-# define TclUCS4Complete(src, length) (((unsigned)(UCHAR(*(src)) - 0xF0) < 5) \
- ? ((length) >= 4) : (UCHAR(*(src)) == 0xED) ? ((length) >= 6) : Tcl_UtfCharComplete((src), (length)))
-MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
+MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
@@ -3227,35 +3435,69 @@ MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
-/* TclWideMUInt -- wide integer used for measurement calculations: */
-#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400))
-# define TclWideMUInt Tcl_WideUInt
-#else
-/* older MSVS may not allow conversions between unsigned __int64 and double) */
-# define TclWideMUInt Tcl_WideInt
-#endif
#ifdef TCL_WIDE_CLICKS
-MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
-MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
+MODULE_SCOPE long long TclpGetWideClicks(void);
+MODULE_SCOPE double TclpWideClicksToNanoseconds(long long clicks);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
#else
# ifdef _WIN32
# define TCL_WIDE_CLICKS 1
-MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
+MODULE_SCOPE long long TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
# define TclpWideClicksToNanoseconds(clicks) \
((double)(clicks) * TclpWideClickInMicrosec() * 1000)
# endif
#endif
-MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);
+MODULE_SCOPE long long TclpGetMicroseconds(void);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr);
+MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp,
+ const char *msg, int length);
+/* Tip 430 */
+MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
+
+
+#if TCL_UTF_MAX > 3
+ MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *);
+ MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int);
+ MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int);
+ MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long);
+ MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int);
+ MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long);
+# undef Tcl_NumUtfChars
+# define Tcl_NumUtfChars TclNumUtfChars
+# undef Tcl_GetCharLength
+# define Tcl_GetCharLength TclGetCharLength
+# undef Tcl_UtfAtIndex
+# define Tcl_UtfAtIndex TclUtfAtIndex
+# undef Tcl_GetRange
+# define Tcl_GetRange TclGetRange
+# undef Tcl_GetUniChar
+# define Tcl_GetUniChar TclGetUniChar
+#else
+# define tclUniCharStringType tclStringType
+# define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj
+# define TclNewUnicodeObj Tcl_NewUnicodeObj
+# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj
+# define TclUniCharNcasecmp Tcl_UniCharNcasecmp
+# define TclUniCharCaseMatch Tcl_UniCharCaseMatch
+# define TclUniCharNcmp Tcl_UniCharNcmp
+# undef TclNumUtfChars
+# define TclNumUtfChars Tcl_NumUtfChars
+# undef TclGetCharLength
+# define TclGetCharLength Tcl_GetCharLength
+# undef TclUtfAtIndex
+# define TclUtfAtIndex Tcl_UtfAtIndex
+# undef TclGetRange
+# define TclGetRange Tcl_GetRange
+# undef TclGetUniChar
+# define TclGetUniChar Tcl_GetUniChar
+#endif
-MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
/*
* Many parsing tasks need a common definition of whitespace.
@@ -3273,59 +3515,31 @@ MODULE_SCOPE int TclIsSpaceProc(int byte);
*----------------------------------------------------------------
*/
-MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd;
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[]);
-MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd;
+#if !defined(TCL_NO_DEPRECATED)
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd;
+#endif
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd;
MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-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 Tcl_ObjCmdProc TclChanCreateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd;
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
-MODULE_SCOPE int TclClockOldscanObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd;
MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler(
Tcl_Time *timePtr, Tcl_TimerProc *proc,
- ClientData clientData);
-MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+ void *clientData);
+MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd;
MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *part1Ptr,
@@ -3333,234 +3547,91 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
int pathc, Tcl_Obj *const pathv[]);
-MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd;
/* 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 Tcl_ObjCmdProc Tcl_AssembleObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd;
MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FconfigureObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd;
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[]);
-MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForeachObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FormatObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GetsObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobalObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_IfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_IncrObjCmd;
MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData,
- Tcl_Interp *interp, int argc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_InterpObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_JoinObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LappendObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LassignObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LeditObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LindexObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LinsertObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LlengthObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ListObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LmapObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LoadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LpopObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrangeObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LremoveObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd;
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,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNamespaceEnsembleCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_OpenObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PackageObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PidObjCmd;
MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-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[]);
-MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PutsObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PwdObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegexpObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegsubObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RenameObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RepresentationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReturnObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ScanObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SeekObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SetObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SplitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SocketObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SourceObjCmd;
MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-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_TimeRateObjCmd(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[]);
-MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SubstObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SwitchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TellObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ThrowObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeRateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TraceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnloadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnsetObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpdateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpvarObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_VariableObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_VwaitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_WhileObjCmd;
/*
*----------------------------------------------------------------
@@ -3613,6 +3684,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3775,6 +3849,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3884,105 +3961,71 @@ MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd;
MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNotOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNotOpCmd;
MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclAddOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclAddOpCmd;
MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclMulOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclMulOpCmd;
MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclAndOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclAndOpCmd;
MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclOrOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclOrOpCmd;
MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclXorOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclXorOpCmd;
MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclPowOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclPowOpCmd;
MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclLshiftOpCmd;
MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclRshiftOpCmd;
MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclModOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclModOpCmd;
MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNeqOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNeqOpCmd;
MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclStrneqOpCmd;
MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclInOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInOpCmd;
MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNiOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNiOpCmd;
MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclMinusOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclMinusOpCmd;
MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclDivOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclDivOpCmd;
MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -4004,12 +4047,47 @@ MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrLtOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrLeOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrGtOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrGeOpCmd(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);
/*
+ * Routines that provide the [string] ensemble functionality. Possible
+ * candidates for public interface.
+ */
+
+MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags);
+MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int start);
+MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int last);
+MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int count, int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int first, int count, Tcl_Obj *insertPtr,
+ int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags);
+
+/* Flag values for the [string] ensemble functions. */
+
+#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */
+#define TCL_STRING_IN_PLACE (1<<1)
+
+/*
* Functions defined in generic/tclVar.c and currently exported only for use
* by the bytecode compiler and engine. Some of these could later be placed in
* the public interface.
@@ -4060,11 +4138,55 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
-MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
+MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
+ * Just for the purposes of command-type registration.
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd;
+
+/*
+ * TIP #462.
+ */
+
+/*
+ * The following enum values give the status of a spawned process.
+ */
+
+typedef enum TclProcessWaitStatus {
+ TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */
+ TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */
+ TCL_PROCESS_EXITED = 1, /* Process has exited. */
+ TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */
+ TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */
+ TCL_PROCESS_UNKNOWN_STATUS = 4
+ /* Child wait status didn't make sense. */
+} TclProcessWaitStatus;
+
+MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
+MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid);
+MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
+ int *codePtr, Tcl_Obj **msgObjPtr,
+ Tcl_Obj **errorObjPtr);
+
+/*
+ * TIP #508: [array default]
+ */
+
+MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr);
+MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr);
+
+/*
* Utility routines for encoding index values as integers. Used by both
* some of the command compilers and by [lsort] and [lsearch].
*/
@@ -4073,13 +4195,40 @@ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
int before, int after, int *indexPtr);
MODULE_SCOPE int TclIndexDecode(int encoded, int endValue);
-MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
-
/* Constants used in index value encoding routines. */
-#define TCL_INDEX_END (-2)
-#define TCL_INDEX_BEFORE (-1)
-#define TCL_INDEX_START (0)
-#define TCL_INDEX_AFTER (INT_MAX)
+#define TCL_INDEX_END ((Tcl_Size)-2)
+#define TCL_INDEX_START ((Tcl_Size)0)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclScaleTime --
+ *
+ * TIP #233 (Virtualized Time): Wrapper around the time virutalisation
+ * rescale function to hide the binding of the clientData.
+ *
+ * This is static inline code; it's like a macro, but a function. It's
+ * used because this is a piece of code that ends up in places that are a
+ * bit performance sensitive.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Updates the time structure (given as an argument) with what the time
+ * should be after virtualisation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline void
+TclScaleTime(
+ Tcl_Time *timePtr)
+{
+ if (timePtr != NULL) {
+ tclScaleTimeProcPtr(timePtr, tclTimeClientData);
+ }
+}
/*
*----------------------------------------------------------------
@@ -4138,7 +4287,7 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
@@ -4146,7 +4295,7 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
/*
* 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'.
+ * 'length == TCL_INDEX_NONE'.
* Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
*/
@@ -4155,10 +4304,10 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
+ && ((objPtr)->bytes != &tclEmptyString)) { \
+ ckfree((objPtr)->bytes); \
} \
- (objPtr)->length = -1; \
+ (objPtr)->length = TCL_INDEX_NONE; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} else { \
@@ -4166,6 +4315,10 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
} \
}
+#if TCL_THREADS && !defined(USE_THREAD_ALLOC)
+# define USE_THREAD_ALLOC 1
+#endif
+
#if defined(PURIFY)
/*
@@ -4176,14 +4329,14 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
*/
# define TclAllocObjStorageEx(interp, objPtr) \
- (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
+ (objPtr) = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
- ckfree((char *) (objPtr))
+ ckfree(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#elif TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
@@ -4197,6 +4350,7 @@ MODULE_SCOPE void TclFreeAllocCache(void *);
MODULE_SCOPE void * TclpGetAllocCache(void);
MODULE_SCOPE void TclpSetAllocCache(void *);
MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE void TclpInitAllocCache(void);
MODULE_SCOPE void TclpFreeAllocCache(void *);
/*
@@ -4247,7 +4401,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
# define USE_TCLALLOC 0
#endif
-#ifdef TCL_THREADS
+#if TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex tclObjMutex;
#endif
@@ -4301,25 +4455,32 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to set a Tcl_Obj's string representation to a
- * copy of the "len" bytes starting at "bytePtr". This code works even if the
- * byte array contains NULLs as long as the length is correct. Because "len"
- * is referenced multiple times, it should be as simple an expression as
- * possible. The ANSI C "prototype" for this macro is:
+ * copy of the "len" bytes starting at "bytePtr". The value of "len" must
+ * not be negative. When "len" is 0, then it is acceptable to pass
+ * "bytePtr" = NULL. When "len" > 0, "bytePtr" must not be NULL, and it
+ * must point to a location from which "len" bytes may be read. These
+ * constraints are not checked here. The validity of the bytes copied
+ * as a value string representation is also not verififed. This macro
+ * must not be called while "objPtr" is being freed or when "objPtr"
+ * already has a string representation. The caller must use
+ * this macro properly. Improper use can lead to dangerous results.
+ * Because "len" is referenced multiple times, take care that it is an
+ * expression with the same value each use.
*
- * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
*
- * This macro should only be called on an unshared objPtr where
- * objPtr->typePtr->freeIntRepProc == NULL
*----------------------------------------------------------------
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
- (objPtr)->bytes = (char *) ckalloc((unsigned int)(len) + 1U); \
- memcpy((objPtr)->bytes, (bytePtr), (len)); \
+ (objPtr)->bytes = (char *)ckalloc((len) + 1U); \
+ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
@@ -4337,12 +4498,13 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclGetString(objPtr) \
- ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
+#undef TclGetStringFromObj
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
- : Tcl_GetStringFromObj((objPtr), (lenPtr)))
+ : (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
@@ -4350,11 +4512,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
* representation. Does not actually reset the rep's bytes. The ANSI C
* "prototype" for this macro is:
*
- * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr);
+ * MODULE_SCOPE void TclFreeInternalRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
-#define TclFreeIntRep(objPtr) \
+#define TclFreeInternalRep(objPtr) \
if ((objPtr)->typePtr != NULL) { \
if ((objPtr)->typePtr->freeIntRepProc != NULL) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
@@ -4362,6 +4524,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
(objPtr)->typePtr = NULL; \
}
+#if !defined(TCL_NO_DEPRECATED)
+# define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr)
+#endif
+
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's string representation.
@@ -4375,18 +4541,68 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
do { \
Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \
if (_isobjPtr->bytes != NULL) { \
- if (_isobjPtr->bytes != tclEmptyStringRep) { \
+ if (_isobjPtr->bytes != &tclEmptyString) { \
ckfree((char *)_isobjPtr->bytes); \
} \
_isobjPtr->bytes = NULL; \
} \
} while (0)
+/*
+ * These form part of the native filesystem support. They are needed here
+ * because we have a few native filesystem functions (which are the same for
+ * win/unix) in this file.
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+MODULE_SCOPE const char *const tclpFileAttrStrings[];
+MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+#ifdef __cplusplus
+}
+#endif
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to test whether an object has a
+ * string representation (or is a 'pure' internal value).
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
#define TclHasStringRep(objPtr) \
((objPtr)->bytes != NULL)
/*
*----------------------------------------------------------------
+ * Macro used by the Tcl core to get the bignum out of the bignum
+ * representation of a Tcl_Obj.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
+ *----------------------------------------------------------------
+ */
+
+#define TclUnpackBignum(objPtr, bignum) \
+ do { \
+ Tcl_Obj *bignumObj = (objPtr); \
+ int bignumPayload = \
+ PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
+ if (bignumPayload == -1) { \
+ (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
+ } else { \
+ (bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
+ (bignum).sign = bignumPayload >> 30; \
+ (bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \
+ (bignum).used = bignumPayload & 0x7FFF; \
+ } \
+ } while (0)
+
+/*
+ *----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
* "prototype" for this macro is:
@@ -4433,19 +4649,19 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
allocated = TCL_MAX_TOKENS; \
} \
newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
- (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ 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))); \
+ allocated * sizeof(Tcl_Token)); \
} \
(available) = allocated; \
if (oldPtr == NULL) { \
memcpy(newPtr, staticPtr, \
- (size_t) ((used) * sizeof(Tcl_Token))); \
+ (used) * sizeof(Tcl_Token)); \
} \
(tokenPtr) = newPtr; \
} \
@@ -4468,10 +4684,17 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
+#if TCL_UTF_MAX > 3
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
+#else
+#define TclUtfToUniChar(str, chPtr) \
+ (((UCHAR(*(str))) < 0x80) ? \
+ ((*(chPtr) = UCHAR(*(str))), 1) \
+ : Tcl_UtfToChar16(str, chPtr))
+#endif
/*
*----------------------------------------------------------------
@@ -4480,28 +4703,23 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
* 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,
+ * MODULE_SCOPE void TclNumUtfCharsM(int numChars, const char *bytes,
* int numBytes);
*----------------------------------------------------------------
*/
-#define TclNumUtfChars(numChars, bytes, numBytes) \
+#define TclNumUtfCharsM(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); \
+ _count += TclNumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
-#define TclUtfPrev(src, start) \
- (((src) < (start)+2) ? (start) : \
- (UCHAR(*((src) - 1))) < 0x80 ? (src)-1 : \
- Tcl_UtfPrev(src, start))
-
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
@@ -4517,31 +4735,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
-#define TclIsPureByteArray(objPtr) \
- (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
+MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
(((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType))
+#define TclHasInternalRep(objPtr, type) \
+ ((objPtr)->typePtr == (type))
+#define TclFetchInternalRep(objPtr, type) \
+ (TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL)
-#define TclIsPureList(objPtr) \
- (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclListType))
-
-/*
- *----------------------------------------------------------------
- * 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
- * this macro is:
- *
- * MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *cs,
- * const Tcl_UniChar *ct, unsigned long n);
- *----------------------------------------------------------------
- */
-
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
-# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
-#else /* !WORDS_BIGENDIAN */
-# define TclUniCharNcmp Tcl_UniCharNcmp
-#endif /* WORDS_BIGENDIAN */
/*
*----------------------------------------------------------------
@@ -4568,7 +4769,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
+MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init;
/*
*----------------------------------------------------------------------
@@ -4580,11 +4781,11 @@ MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
*----------------------------------------------------------------------
*/
-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;
+MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit;
+MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init;
+MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init;
+MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init;
+MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
/*
*----------------------------------------------------------------
@@ -4605,51 +4806,25 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* core. They should only be called on unshared objects. The ANSI C
* "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue);
- * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue);
- * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, int intValue);
- * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
-#define TclSetLongObj(objPtr, i) \
+#define TclSetIntObj(objPtr, i) \
do { \
+ Tcl_ObjInternalRep ir; \
+ ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.longValue = (long)(i); \
- (objPtr)->typePtr = &tclIntType; \
+ Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
} while (0)
-#define TclSetIntObj(objPtr, l) \
- TclSetLongObj(objPtr, l)
-
-/*
- * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
- * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
- * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
- * value of strings like: "yes", "no", "true", "false", "on", "off".
- */
-
-#define TclSetBooleanObj(objPtr, b) \
- TclSetLongObj(objPtr, (b)!=0);
-
-#ifndef TCL_WIDE_INT_IS_LONG
-#define TclSetWideIntObj(objPtr, w) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclWideIntType; \
- } while (0)
-#endif
-
#define TclSetDoubleObj(objPtr, d) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType; \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.doubleValue = (double) d; \
+ TclInvalidateStringRep(objPtr); \
+ Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
@@ -4658,38 +4833,48 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
- * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
- * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
- * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
- * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
- * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
+ * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
+ * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
-#define TclNewLongObj(objPtr, i) \
+#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
- (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewIntObj(objPtr, l) \
- TclNewLongObj(objPtr, l)
+#define TclNewUIntObj(objPtr, uw) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ Tcl_WideUInt uw_ = (uw); \
+ if (uw_ > WIDE_MAX) { \
+ mp_int bignumValue_; \
+ if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \
+ Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
+ } \
+ TclSetBignumInternalRep((objPtr), &bignumValue_); \
+ } else { \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
+ (objPtr)->typePtr = &tclIntType; \
+ } \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
-/*
- * NOTE: There is to be no such thing as a "pure" boolean.
- * See comment above TclSetBooleanObj macro above.
- */
-#define TclNewBooleanObj(objPtr, b) \
- TclNewLongObj((objPtr), (b)!=0)
+#define TclNewIndexObj(objPtr, w) \
+ TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
do { \
@@ -4713,14 +4898,26 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewIntObj(objPtr, i) \
- (objPtr) = Tcl_NewIntObj(i)
+#define TclNewIntObj(objPtr, w) \
+ (objPtr) = Tcl_NewWideIntObj(w)
-#define TclNewLongObj(objPtr, l) \
- (objPtr) = Tcl_NewLongObj(l)
+#define TclNewUIntObj(objPtr, uw) \
+ do { \
+ Tcl_WideUInt uw_ = (uw); \
+ if (uw_ > WIDE_MAX) { \
+ mp_int bignumValue_; \
+ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \
+ (objPtr) = Tcl_NewBignumObj(&bignumValue_); \
+ } else { \
+ (objPtr) = NULL; \
+ } \
+ } else { \
+ (objPtr) = Tcl_NewWideIntObj(uw_); \
+ } \
+ } while (0)
-#define TclNewBooleanObj(objPtr, b) \
- (objPtr) = Tcl_NewBooleanObj(b)
+#define TclNewIndexObj(objPtr, w) \
+ TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
@@ -4734,7 +4931,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
- TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+ TclNewStringObj((objPtr), (sLiteral), sizeof(sLiteral "") - 1)
/*
*----------------------------------------------------------------
@@ -4747,41 +4944,35 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#define TclDStringAppendLiteral(dsPtr, sLiteral) \
- Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+ Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1)
#define TclDStringClear(dsPtr) \
Tcl_DStringSetLength((dsPtr), 0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
- * The ANSI C "prototypes" for these macros are:
+ * (deprecated) The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE int TclIsInfinite(double d);
* MODULE_SCOPE int TclIsNaN(double d);
*/
-#ifdef _MSC_VER
-# define TclIsInfinite(d) (!(_finite((d))))
-# define TclIsNaN(d) (_isnan((d)))
-#else
-# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX)
-# ifdef NO_ISNAN
-# define TclIsNaN(d) ((d) != (d))
-# else
-# define TclIsNaN(d) (isnan(d))
-# endif
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+# define TclIsInfinite(d) isinf(d)
+# define TclIsNaN(d) isnan(d)
#endif
/*
- * ----------------------------------------------------------------------
- * Macro to use to find the offset of a field in a structure. Computes number
- * of bytes from beginning of structure to a given field.
+ * Macro to use to find the offset of a field in astructure.
+ * Computes number of bytes from beginning of structure to a given field.
*/
-#ifdef offsetof
-#define TclOffset(type, field) ((int) offsetof(type, field))
-#else
-#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field))
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+# define TclOffset(type, field) ((int) offsetof(type, field))
+#endif
+/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */
+#ifndef offsetof
+# define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field))
#endif
/*
@@ -4801,10 +4992,30 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* the internal stubs, but the core can use the macro instead.
*/
-#define TclCleanupCommandMacro(cmdPtr) \
- if ((cmdPtr)->refCount-- <= 1) { \
- ckfree((char *) (cmdPtr));\
- }
+#define TclCleanupCommandMacro(cmdPtr) \
+ do { \
+ if ((cmdPtr)->refCount-- <= 1) { \
+ ckfree(cmdPtr); \
+ } \
+ } while (0)
+
+
+/*
+ * inside this routine crement refCount first incase cmdPtr is replacing itself
+ */
+#define TclRoutineAssign(location, cmdPtr) \
+ do { \
+ (cmdPtr)->refCount++; \
+ if ((location) != NULL \
+ && (location--) <= 1) { \
+ ckfree(((location))); \
+ } \
+ (location) = (cmdPtr); \
+ } while (0)
+
+
+#define TclRoutineHasName(cmdPtr) \
+ ((cmdPtr)->hPtr != NULL)
/*
*----------------------------------------------------------------
@@ -4867,12 +5078,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
- memPtr = (ClientData) (_objPtr); \
+ *(void **)&(memPtr) = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
- TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
+ TclFreeObjStorageEx((interp), (Tcl_Obj *)(memPtr)); \
TclIncrObjsFreed(); \
} while (0)
@@ -4882,12 +5093,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
- memPtr = (ClientData) _objPtr; \
+ *(void **)&(memPtr) = (void *)_objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
- Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
+ Tcl_Obj *_objPtr = (Tcl_Obj *)(memPtr); \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
_objPtr->refCount = 1; \
@@ -4931,7 +5142,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
- ClientData data[4];
+ void *data[4];
struct NRE_callback *nextPtr;
} NRE_callback;
@@ -4946,10 +5157,10 @@ typedef struct NRE_callback {
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->data[0] = (void *)(data0); \
+ _callbackPtr->data[1] = (void *)(data1); \
+ _callbackPtr->data[2] = (void *)(data2); \
+ _callbackPtr->data[3] = (void *)(data3); \
_callbackPtr->nextPtr = TOP_CB(interp); \
TOP_CB(interp) = _callbackPtr; \
} while (0)
@@ -4961,7 +5172,7 @@ typedef struct NRE_callback {
#else
#define TCLNR_ALLOC(interp, ptr) \
((ptr) = ((void *)ckalloc(sizeof(NRE_callback))))
-#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
@@ -4972,7 +5183,7 @@ typedef struct NRE_callback {
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
-#include "tclTomMathDecls.h"
+
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc(size) TclpAlloc(size)
@@ -4981,11 +5192,32 @@ typedef struct NRE_callback {
#endif
/*
+ * Special hack for macOS, where the static linker (technically the 'ar'
+ * command) hates empty object files, and accepts no flags to make it shut up.
+ *
+ * These symbols are otherwise completely useless.
+ *
+ * They can't be written to or written through. They can't be seen by any
+ * other code. They use a separate attribute (supported by all macOS
+ * compilers, which are derivatives of clang or gcc) to stop the compilation
+ * from moaning. They will be excluded during the final linking stage.
+ *
+ * Other platforms get nothing at all. That's good.
+ */
+
+#ifdef MAC_OSX_TCL
+#define TCL_MAC_EMPTY_FILE(name) \
+ static __attribute__((used)) const void *const TclUnusedFile_ ## name = NULL;
+#else
+#define TCL_MAC_EMPTY_FILE(name)
+#endif /* MAC_OSX_TCL */
+
+/*
* Other externals.
*/
-MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
- * (if changed with tcl-env). */
+MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
+ * (if changed with tcl-env). */
#endif /* _TCLINT */
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index e958733..ffd559d 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -27,21 +27,22 @@
# endif
#endif
-/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_CreateNamespace
-#undef Tcl_DeleteNamespace
-#undef Tcl_AppendExportList
-#undef Tcl_Export
-#undef Tcl_Import
-#undef Tcl_ForgetImport
-#undef Tcl_GetCurrentNamespace
-#undef Tcl_GetGlobalNamespace
-#undef Tcl_FindNamespace
-#undef Tcl_FindCommand
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
-#undef Tcl_SetStartupScript
-#undef Tcl_GetStartupScript
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+# define tclGetIntForIndex tcl_GetIntForIndex
+/* Those macro's are especially for Itcl 3.4 compatibility */
+# define tclCreateNamespace tcl_CreateNamespace
+# define tclDeleteNamespace tcl_DeleteNamespace
+# define tclAppendExportList tcl_AppendExportList
+# define tclExport tcl_Export
+# define tclImport tcl_Import
+# define tclForgetImport tcl_ForgetImport
+# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace
+# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace
+# define tclFindNamespace tcl_FindNamespace
+# define tclFindCommand tcl_FindCommand
+# define tclGetCommandFromObj tcl_GetCommandFromObj
+# define tclGetCommandFullName tcl_GetCommandFullName
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -74,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr);
EXTERN int TclCopyAndCollapse(int count, const char *src,
char *dst);
/* 8 */
-EXTERN int TclCopyChannelOld(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
/* 9 */
@@ -94,7 +96,7 @@ EXTERN void TclDeleteVars(Interp *iPtr,
TclVarHashTable *tablePtr);
/* Slot 13 is reserved */
/* 14 */
-EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags);
+EXTERN int TclDumpMemoryInfo(void *clientData, int flags);
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
@@ -112,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp,
/* 23 */
EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
-EXTERN int TclFormatInt(char *buffer, long n);
+EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n);
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
/* Slot 26 is reserved */
@@ -128,7 +130,8 @@ EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr);
/* Slot 33 is reserved */
/* 34 */
-EXTERN int TclGetIntForIndex(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_GetIntForIndex")
+int TclGetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr);
/* Slot 35 is reserved */
/* Slot 36 is reserved */
@@ -150,9 +153,10 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str,
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command);
/* 42 */
-EXTERN CONST86 char * TclpGetUserHome(const char *name,
+EXTERN const char * TclpGetUserHome(const char *name,
Tcl_DString *bufferPtr);
-/* Slot 43 is reserved */
+/* 43 */
+EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void);
/* 44 */
EXTERN int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
@@ -170,11 +174,11 @@ EXTERN void TclInitCompiledLocals(Tcl_Interp *interp,
EXTERN int TclInterpInit(Tcl_Interp *interp);
/* Slot 52 is reserved */
/* 53 */
-EXTERN int TclInvokeObjectCommand(ClientData clientData,
+EXTERN int TclInvokeObjectCommand(void *clientData,
Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+ const char **argv);
/* 54 */
-EXTERN int TclInvokeStringCommand(ClientData clientData,
+EXTERN int TclInvokeStringCommand(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 55 */
@@ -194,7 +198,7 @@ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr);
/* 62 */
EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr);
/* 63 */
-EXTERN int TclObjInterpProc(ClientData clientData,
+EXTERN int TclObjInterpProc(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 64 */
@@ -205,24 +209,25 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
/* Slot 67 is reserved */
/* Slot 68 is reserved */
/* 69 */
-EXTERN char * TclpAlloc(unsigned int size);
+EXTERN void * TclpAlloc(unsigned int size);
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
/* 74 */
-EXTERN void TclpFree(char *ptr);
+EXTERN void TclpFree(void *ptr);
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
-EXTERN void TclpGetTime(Tcl_Time *time);
+TCL_DEPRECATED("")
+void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
-EXTERN char * TclpRealloc(char *ptr, unsigned int size);
+EXTERN void * TclpRealloc(void *ptr, unsigned int size);
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
@@ -230,7 +235,8 @@ EXTERN char * TclpRealloc(char *ptr, unsigned int size);
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
-EXTERN char * TclPrecTraceProc(ClientData clientData,
+TCL_DEPRECATED("")
+char * TclPrecTraceProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
/* 89 */
@@ -245,7 +251,7 @@ EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
const char *description,
const char *procName);
/* 93 */
-EXTERN void TclProcDeleteProc(ClientData clientData);
+EXTERN void TclProcDeleteProc(void *clientData);
/* Slot 94 is reserved */
/* Slot 95 is reserved */
/* 96 */
@@ -259,14 +265,15 @@ EXTERN int TclServiceIdle(void);
/* Slot 99 is reserved */
/* Slot 100 is reserved */
/* 101 */
-EXTERN CONST86 char * TclSetPreInitScript(const char *string);
+EXTERN const char * TclSetPreInitScript(const char *string);
/* 102 */
EXTERN void TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
const char *proto, int *portPtr);
/* 104 */
-EXTERN int TclSockMinimumBuffersOld(int sock, int size);
+TCL_DEPRECATED("")
+int TclSockMinimumBuffersOld(int sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
@@ -283,22 +290,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
-EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
+EXTERN int TclAppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
/* 113 */
-EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- const char *name, ClientData clientData,
+EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
+ const char *name, void *clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
-EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
+EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
-EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst);
/* 116 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
-EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
@@ -313,23 +320,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
-EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
+EXTERN int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
-EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
+EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
-EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
+EXTERN void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
-EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
-EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp);
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
/* 127 */
-EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
@@ -347,25 +354,25 @@ EXTERN void Tcl_SetNamespaceResolvers(
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 132 */
-EXTERN int TclpHasSockets(Tcl_Interp *interp);
+TCL_DEPRECATED("")
+int TclpHasSockets(Tcl_Interp *interp);
/* 133 */
-EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT);
+TCL_DEPRECATED("")
+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 */
/* 138 */
-EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
- Tcl_DString *valuePtr);
+EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr);
/* Slot 139 is reserved */
/* Slot 140 is reserved */
/* 141 */
-EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
- Tcl_DString *cwdPtr);
+EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
- ClientData clientData);
+ void *clientData);
/* 143 */
EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr,
Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
@@ -400,15 +407,17 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
/* 158 */
-EXTERN void TclSetStartupScriptFileName(const char *filename);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptFileName(const char *filename);
/* 159 */
-EXTERN const char * TclGetStartupScriptFileName(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
/* 162 */
-EXTERN void TclChannelEventScriptInvoker(ClientData clientData,
+EXTERN void TclChannelEventScriptInvoker(void *clientData,
int flags);
/* 163 */
EXTERN const void * TclGetInstructionTable(void);
@@ -421,9 +430,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
/* 167 */
-EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
/* 168 */
-EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
@@ -456,16 +467,18 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
/* 178 */
-EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
+EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
-EXTERN struct tm * TclpLocaltime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
-EXTERN struct tm * TclpGmtime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
@@ -568,13 +581,13 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
/* 236 */
-EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
+TCL_DEPRECATED("use Tcl_BackgroundException")
+void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
-EXTERN int TclNRInterpProc(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
/* 239 */
EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
Tcl_Obj *procNameObj, int skip,
@@ -605,15 +618,15 @@ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp,
/* 248 */
EXTERN int TclCopyChannel(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
- Tcl_WideInt toRead, Tcl_Obj *cmdPtr);
+ long long toRead, Tcl_Obj *cmdPtr);
/* 249 */
EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr);
/* 250 */
-EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
+EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags,
int force);
/* 251 */
-EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
+EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes,
int length, int flags);
/* 252 */
EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
@@ -638,15 +651,20 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags);
/* 257 */
-EXTERN void TclStaticPackage(Tcl_Interp *interp,
+EXTERN void TclStaticLibrary(Tcl_Interp *interp,
const char *prefix,
- Tcl_PackageInitProc *initProc,
- Tcl_PackageInitProc *safeInitProc);
-/* Slot 258 is reserved */
+ Tcl_LibraryInitProc *initProc,
+ Tcl_LibraryInitProc *safeInitProc);
+/* 258 */
+EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj);
/* Slot 259 is reserved */
-/* Slot 260 is reserved */
+/* 260 */
+EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace,
+ size_t endSpace);
/* 261 */
-EXTERN void TclUnusedStubEntry(void);
+EXTERN void TclListObjValidate(Tcl_Interp *interp,
+ Tcl_Obj *listObj);
typedef struct TclIntStubs {
int magic;
@@ -660,13 +678,13 @@ typedef struct TclIntStubs {
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 (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
+ TCL_DEPRECATED_API("") 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);
- int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */
+ int (*tclDumpMemoryInfo) (void *clientData, int flags); /* 14 */
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);
@@ -676,7 +694,7 @@ typedef struct TclIntStubs {
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 */
+ int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
@@ -686,7 +704,7 @@ typedef struct TclIntStubs {
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 */
+ TCL_DEPRECATED_API("Use Tcl_GetIntForIndex") int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
void (*reserved35)(void);
void (*reserved36)(void);
int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
@@ -694,8 +712,8 @@ typedef struct TclIntStubs {
Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
- CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
- void (*reserved43)(void);
+ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
+ Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */
int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
@@ -705,8 +723,8 @@ typedef struct TclIntStubs {
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
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 (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
+ int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
void (*reserved57)(void);
@@ -715,37 +733,37 @@ typedef struct TclIntStubs {
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 (*tclObjInterpProc) (void *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 * (*tclpAlloc) (unsigned int size); /* 69 */
void (*reserved70)(void);
void (*reserved71)(void);
void (*reserved72)(void);
void (*reserved73)(void);
- void (*tclpFree) (char *ptr); /* 74 */
+ void (*tclpFree) (void *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
- void (*tclpGetTime) (Tcl_Time *time); /* 77 */
+ TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
- char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
+ void * (*tclpRealloc) (void *ptr, unsigned int size); /* 81 */
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 */
+ TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (void *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);
void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */
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 (*tclProcDeleteProc) (void *clientData); /* 93 */
void (*reserved94)(void);
void (*reserved95)(void);
int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
@@ -753,10 +771,10 @@ typedef struct TclIntStubs {
int (*tclServiceIdle) (void); /* 98 */
void (*reserved99)(void);
void (*reserved100)(void);
- CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
+ const 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 (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
+ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
void (*reserved105)(void);
void (*reserved106)(void);
void (*reserved107)(void);
@@ -764,37 +782,37 @@ typedef struct TclIntStubs {
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
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 */
- 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 (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
+ Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
+ int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ Tcl_Namespace * (*tclFindNamespace) (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_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 */
+ int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
+ Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
+ void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
+ Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
+ Tcl_Namespace * (*tclGetGlobalNamespace_) (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 (*tclImport) (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 */
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 */
+ TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
+ TCL_DEPRECATED_API("") 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 */
+ const 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 */
+ const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
+ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
@@ -810,17 +828,17 @@ typedef struct TclIntStubs {
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
- const char * (*tclGetStartupScriptFileName) (void); /* 159 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
- void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
+ void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */
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 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") 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 */
@@ -830,12 +848,12 @@ typedef struct TclIntStubs {
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
- Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
+ void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
- struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
- struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
@@ -888,9 +906,9 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
+ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
- int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
+ int (*tclNRInterpProc) (void *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 */
@@ -900,20 +918,20 @@ typedef struct TclIntStubs {
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 */
+ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
- void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
- int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
+ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
+ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */
Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */
- void (*tclStaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
- void (*reserved258)(void);
+ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
+ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
void (*reserved259)(void);
- void (*reserved260)(void);
- void (*tclUnusedStubEntry) (void); /* 261 */
+ Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 260 */
+ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -996,7 +1014,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-/* Slot 43 is reserved */
+#define TclGetObjInterpProc2 \
+ (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */
#define TclGuessPackageName \
(tclIntStubsPtr->tclGuessPackageName) /* 44 */
#define TclHideUnsafeCommands \
@@ -1101,38 +1120,38 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#define Tcl_AppendExportList \
- (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#define Tcl_CreateNamespace \
- (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#define Tcl_DeleteNamespace \
- (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#define Tcl_Export \
- (tclIntStubsPtr->tcl_Export) /* 115 */
-#define Tcl_FindCommand \
- (tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#define Tcl_FindNamespace \
- (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+#define TclAppendExportList \
+ (tclIntStubsPtr->tclAppendExportList) /* 112 */
+#define TclCreateNamespace \
+ (tclIntStubsPtr->tclCreateNamespace) /* 113 */
+#define TclDeleteNamespace \
+ (tclIntStubsPtr->tclDeleteNamespace) /* 114 */
+#define TclExport \
+ (tclIntStubsPtr->tclExport) /* 115 */
+#define TclFindCommand \
+ (tclIntStubsPtr->tclFindCommand) /* 116 */
+#define TclFindNamespace \
+ (tclIntStubsPtr->tclFindNamespace) /* 117 */
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#define Tcl_ForgetImport \
- (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#define Tcl_GetCommandFromObj \
- (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#define Tcl_GetCommandFullName \
- (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#define Tcl_GetCurrentNamespace \
- (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#define Tcl_GetGlobalNamespace \
- (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+#define TclForgetImport \
+ (tclIntStubsPtr->tclForgetImport) /* 121 */
+#define TclGetCommandFromObj \
+ (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */
+#define TclGetCommandFullName \
+ (tclIntStubsPtr->tclGetCommandFullName) /* 123 */
+#define TclGetCurrentNamespace_ \
+ (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */
+#define TclGetGlobalNamespace_ \
+ (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#define Tcl_Import \
- (tclIntStubsPtr->tcl_Import) /* 127 */
+#define TclImport \
+ (tclIntStubsPtr->tclImport) /* 127 */
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#define Tcl_PushCallFrame \
@@ -1223,10 +1242,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-#define Tcl_SetStartupScript \
- (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
-#define Tcl_GetStartupScript \
- (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
+#define TclSetStartupScript \
+ (tclIntStubsPtr->tclSetStartupScript) /* 178 */
+#define TclGetStartupScript \
+ (tclIntStubsPtr->tclGetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
@@ -1341,8 +1360,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCopyChannel) /* 248 */
#define TclDoubleDigits \
(tclIntStubsPtr->tclDoubleDigits) /* 249 */
-#define TclSetSlaveCancelFlags \
- (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */
+#define TclSetChildCancelFlags \
+ (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */
#define TclRegisterLiteral \
(tclIntStubsPtr->tclRegisterLiteral) /* 251 */
#define TclPtrGetVar \
@@ -1355,13 +1374,15 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
-#define TclStaticPackage \
- (tclIntStubsPtr->tclStaticPackage) /* 257 */
-/* Slot 258 is reserved */
+#define TclStaticLibrary \
+ (tclIntStubsPtr->tclStaticLibrary) /* 257 */
+#define TclpCreateTemporaryDirectory \
+ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
/* Slot 259 is reserved */
-/* Slot 260 is reserved */
-#define TclUnusedStubEntry \
- (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */
+#define TclListTestObj \
+ (tclIntStubsPtr->tclListTestObj) /* 260 */
+#define TclListObjValidate \
+ (tclIntStubsPtr->tclListObjValidate) /* 261 */
#endif /* defined(USE_TCL_STUBS) */
@@ -1370,63 +1391,42 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#undef TclGetStartupScriptFileName
-#undef TclSetStartupScriptFileName
-#undef TclGetStartupScriptPath
-#undef TclSetStartupScriptPath
-#undef TclBackgroundException
+#if defined(USE_TCL_STUBS)
+# undef TclGetStartupScriptFileName
+# undef TclSetStartupScriptFileName
+# undef TclGetStartupScriptPath
+# undef TclSetStartupScriptPath
+# undef TclBackgroundException
+# undef TclSetStartupScript
+# undef TclGetStartupScript
+# undef TclGetIntForIndex
+# undef TclCreateNamespace
+# undef TclDeleteNamespace
+# undef TclAppendExportList
+# undef TclExport
+# undef TclImport
+# undef TclForgetImport
+# undef TclGetCurrentNamespace_
+# undef TclGetGlobalNamespace_
+# undef TclFindNamespace
+# undef TclFindCommand
+# undef TclGetCommandFromObj
+# undef TclGetCommandFullName
+# undef TclCopyChannelOld
+# undef TclSockMinimumBuffersOld
+# undef Tcl_StaticLibrary
+# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary)
+#endif
+
+#undef TclGuessPackageName
#undef TclUnusedStubEntry
+#undef TclSetPreInitScript
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
-
-#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
-# undef Tcl_SetStartupScript
-# define Tcl_SetStartupScript \
- (tclStubsPtr->tcl_SetStartupScript) /* 622 */
-# undef Tcl_GetStartupScript
-# define Tcl_GetStartupScript \
- (tclStubsPtr->tcl_GetStartupScript) /* 623 */
-# undef Tcl_CreateNamespace
-# define Tcl_CreateNamespace \
- (tclStubsPtr->tcl_CreateNamespace) /* 506 */
-# undef Tcl_DeleteNamespace
-# define Tcl_DeleteNamespace \
- (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
-# undef Tcl_AppendExportList
-# define Tcl_AppendExportList \
- (tclStubsPtr->tcl_AppendExportList) /* 508 */
-# undef Tcl_Export
-# define Tcl_Export \
- (tclStubsPtr->tcl_Export) /* 509 */
-# undef Tcl_Import
-# define Tcl_Import \
- (tclStubsPtr->tcl_Import) /* 510 */
-# undef Tcl_ForgetImport
-# define Tcl_ForgetImport \
- (tclStubsPtr->tcl_ForgetImport) /* 511 */
-# undef Tcl_GetCurrentNamespace
-# define Tcl_GetCurrentNamespace \
- (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
-# undef Tcl_GetGlobalNamespace
-# define Tcl_GetGlobalNamespace \
- (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
-# undef Tcl_FindNamespace
-# define Tcl_FindNamespace \
- (tclStubsPtr->tcl_FindNamespace) /* 514 */
-# undef Tcl_FindCommand
-# define Tcl_FindCommand \
- (tclStubsPtr->tcl_FindCommand) /* 515 */
-# undef Tcl_GetCommandFromObj
-# define Tcl_GetCommandFromObj \
- (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
-# undef Tcl_GetCommandFullName
-# define Tcl_GetCommandFullName \
- (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+#define TclObjInterpProc2 TclGetObjInterpProc2()
+#ifndef TCL_NO_DEPRECATED
+# define TclSetPreInitScript Tcl_SetPreInitScript
+# define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0)
#endif
-#undef TclCopyChannelOld
-#undef TclSockMinimumBuffersOld
-
-#define TclSetChildCancelFlags TclSetSlaveCancelFlags
-
#endif /* _TCLINTDECLS */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 7034fc3..bd8d8e5 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -110,7 +110,7 @@ EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -185,7 +185,7 @@ EXTERN void TclWinFlushDirtyChannels(void);
/* 28 */
EXTERN void TclWinResetInterfaces(void);
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -261,7 +261,7 @@ EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -302,7 +302,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
@@ -335,7 +335,7 @@ typedef struct TclIntPlatStubs {
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -368,7 +368,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
@@ -570,6 +570,11 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
+#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# undef TclWinConvertError
+# define TclWinConvertError Tcl_WinConvertError
+#endif
+
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa
@@ -588,13 +593,21 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
# undef TclWinGetServByName
# undef TclWinGetSockOpt
# undef TclWinSetSockOpt
-# define TclWinNToHS ntohs
-# define TclWinGetServByName getservbyname
-# define TclWinGetSockOpt getsockopt
-# define TclWinSetSockOpt setsockopt
+# undef TclWinGetPlatformId
+# undef TclWinResetInterfaces
+# undef TclWinSetInterfaces
+# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define TclWinNToHS ntohs
+# define TclWinGetServByName getservbyname
+# define TclWinGetSockOpt getsockopt
+# define TclWinSetSockOpt setsockopt
+# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# define TclWinResetInterfaces() /* nop */
+# define TclWinSetInterfaces(dummy) /* nop */
+# endif /* TCL_NO_DEPRECATED */
#else
# undef TclpGetPid
-# define TclpGetPid(pid) ((unsigned long) (pid))
+# define TclpGetPid(pid) ((int)(size_t)(pid))
#endif
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 2633a18..ad24d28 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -4,14 +4,15 @@
* This file implements the "interp" command which allows creation and
* manipulation of Tcl interpreters from within Tcl scripts.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 2004 Donal K. Fellows
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2004 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 <assert.h>
/*
* A pointer to a string that holds an initialization script that if non-NULL
@@ -222,9 +223,6 @@ static int AliasDelete(Tcl_Interp *interp,
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
static Tcl_ObjCmdProc AliasNRCmd;
static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
@@ -254,8 +252,6 @@ static int ChildInvokeHidden(Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int ChildMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *childInterp);
-static int ChildObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
static Tcl_CmdDeleteProc ChildObjCmdDeleteProc;
static int ChildRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *childInterp, int objc,
@@ -286,7 +282,7 @@ static Tcl_ObjCmdProc NRChildCmd;
/*
*----------------------------------------------------------------------
*
- * TclSetPreInitScript --
+ * Tcl_SetPreInitScript --
*
* This routine is used to change the value of the internal variable,
* tclPreInitScript.
@@ -301,7 +297,7 @@ static Tcl_ObjCmdProc NRChildCmd;
*/
const char *
-TclSetPreInitScript(
+Tcl_SetPreInitScript(
const char *string) /* Pointer to a script. */
{
const char *prevString = tclPreInitScript;
@@ -328,13 +324,24 @@ TclSetPreInitScript(
*----------------------------------------------------------------------
*/
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being initialized. */
+ char name[4];
+} PkgName;
+
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
+ PkgName pkgName = {NULL, "tcl"};
+ PkgName **names = (PkgName **)TclInitPkgFiles(interp);
+ int result = TCL_ERROR;
+
+ pkgName.nextPtr = *names;
+ *names = &pkgName;
if (tclPreInitScript != NULL) {
- if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return TCL_ERROR;
+ if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
+ goto end;
}
}
@@ -379,7 +386,7 @@ Tcl_Init(
* alternate tclInit command before calling Tcl_Init().
*/
- return Tcl_Eval(interp,
+ result = Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
" proc tclInit {} {\n"
" global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -400,6 +407,7 @@ Tcl_Init(
" } else {\n"
" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
" }\n"
+" lappend scripts {::tcl::zipfs::tcl_library_init}\n"
" lappend scripts {\n"
"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
"set grandParentDir [file dirname $parentDir]\n"
@@ -407,6 +415,7 @@ Tcl_Init(
" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
" {file join $parentDir library} \\\n"
" {file join $grandParentDir library} \\\n"
+" {file join $grandParentDir tcl[info tclversion] library} \\\n"
" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
" {\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
@@ -441,7 +450,11 @@ Tcl_Init(
" error $msg\n"
" }\n"
"}\n"
-"tclInit");
+"tclInit", -1, 0);
+
+end:
+ *names = (*names)->nextPtr;
+ return result;
}
/*
@@ -510,7 +523,7 @@ TclInterpInit(
static void
InterpInfoDeleteProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
@@ -589,7 +602,7 @@ InterpInfoDeleteProc(
int
Tcl_InterpObjCmd(
- ClientData clientData, /* Unused. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -599,7 +612,7 @@ Tcl_InterpObjCmd(
static int
NRInterpCmd(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -609,27 +622,38 @@ NRInterpCmd(
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
+ "eval", "exists", "expose", "hide",
+ "hidden", "issafe", "invokehidden",
+ "limit", "marktrusted", "recursionlimit",
+ "share", "slaves", "target", "transfer",
+ NULL
+ };
+ static const char *const optionsNoSlaves[] = {
+ "alias", "aliases", "bgerror", "cancel",
+ "children", "create", "debug", "delete",
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
- "slaves", "share", "target", "transfer",
- NULL
+ "share", "target", "transfer", NULL
};
enum interpOptionEnum {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
OPT_CHILDREN, 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_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
+ OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
+ OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
+ OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], options,
+ "option", 0, &index) != TCL_OK) {
+ /* Don't report the "slaves" option as possibility */
+ Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves,
+ "option", 0, &index);
return TCL_ERROR;
}
switch ((enum interpOptionEnum)index) {
@@ -639,7 +663,7 @@ NRInterpCmd(
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?");
+ "childPath childCmd ?parentPath parentCmd? ?arg ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
@@ -1401,7 +1425,8 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd
+ && cmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
@@ -1456,7 +1481,8 @@ TclPreventAliasLoop(
* Otherwise we do not have a loop.
*/
- if (aliasCmdPtr->objProc != AliasObjCmd) {
+ if (aliasCmdPtr->objProc != TclAliasObjCmd
+ && aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *)aliasCmdPtr->objClientData;
@@ -1520,12 +1546,12 @@ AliasCreate(
if (childInterp == parentInterp) {
aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
+ aliasPtr, AliasObjCmdDeleteProc);
} else {
- aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
+ TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, childInterp,
@@ -1762,7 +1788,7 @@ AliasList(
/*
*----------------------------------------------------------------------
*
- * AliasObjCmd --
+ * TclAliasObjCmd, TclLocalAliasObjCmd --
*
* This is the function that services invocations of aliases in a child
* interpreter. One such command exists for each alias. When invoked,
@@ -1770,6 +1796,11 @@ AliasList(
* parent interpreter as designated by the Alias record associated with
* this command.
*
+ * TclLocalAliasObjCmd is a stripped down version used when the source
+ * and target interpreters of the alias are the same. That lets a number
+ * of safety precautions be avoided: the state is much more precisely
+ * known.
+ *
* Results:
* A standard Tcl result.
*
@@ -1792,7 +1823,7 @@ AliasNRCmd(
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
- List *listRep;
+ ListRep listRep;
int flags = TCL_EVAL_INVOKE;
/*
@@ -1804,10 +1835,15 @@ AliasNRCmd(
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
+ /* TODO - encapsulate this into tclListObj.c */
listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = listPtr->internalRep.twoPtrValue.ptr1;
- listRep->elemCount = cmdc;
- cmdv = &listRep->elements;
+ ListObjGetRep(listPtr, &listRep);
+ cmdv = ListRepElementsBase(&listRep);
+ listRep.storePtr->numUsed = cmdc;
+ if (listRep.spanPtr) {
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
@@ -1829,8 +1865,8 @@ AliasNRCmd(
return Tcl_NREvalObj(interp, listPtr, flags);
}
-static int
-AliasObjCmd(
+int
+TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -1919,6 +1955,73 @@ AliasObjCmd(
return result;
#undef ALIAS_CMDV_PREALLOC
}
+
+int
+TclLocalAliasObjCmd(
+ ClientData clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+#define ALIAS_CMDV_PREALLOC 10
+ Alias *aliasPtr = (Alias *)clientData;
+ int result, prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble;
+
+ /*
+ * Append the arguments to the command prefix and invoke the command in
+ * the global namespace.
+ */
+
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+ if (cmdc <= ALIAS_CMDV_PREALLOC) {
+ cmdv = cmdArr;
+ } else {
+ cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
+ }
+
+ memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
+ memcpy(cmdv+prefc, objv+1, (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.
+ */
+
+ isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv);
+
+ /*
+ * Execute the target command in the target interpreter.
+ */
+
+ result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE);
+
+ /*
+ * Clean up the ensemble rewrite info if we set it in the first place.
+ */
+
+ if (isRootEnsemble) {
+ TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1);
+ }
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_DecrRefCount(cmdv[i]);
+ }
+ if (cmdv != cmdArr) {
+ TclStackFree(interp, cmdv);
+ }
+ return result;
+#undef ALIAS_CMDV_PREALLOC
+}
/*
*----------------------------------------------------------------------
@@ -2218,7 +2321,7 @@ GetInterp(
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
- if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
@@ -2274,7 +2377,7 @@ ChildBgerror(
if (objc) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
+ if (TCL_ERROR == TclListObjLengthM(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cmdPrefix must be list of length >= 1", -1));
@@ -2321,7 +2424,7 @@ ChildCreate(
int isNew, objc;
Tcl_Obj **objv;
- if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
@@ -2358,10 +2461,10 @@ ChildCreate(
childPtr->childEntryPtr = hPtr;
childPtr->childInterp = childInterp;
childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path,
- ChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc);
+ TclChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc);
Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, childPtr);
- Tcl_SetVar(childInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(childInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
@@ -2371,7 +2474,7 @@ ChildCreate(
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
- if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
+ if (TclMakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
@@ -2426,7 +2529,7 @@ ChildCreate(
/*
*----------------------------------------------------------------------
*
- * ChildObjCmd --
+ * TclChildObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each child interpreter.
@@ -2440,8 +2543,8 @@ ChildCreate(
*----------------------------------------------------------------------
*/
-static int
-ChildObjCmd(
+int
+TclChildObjCmd(
ClientData clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2473,7 +2576,7 @@ NRChildCmd(
};
if (childInterp == NULL) {
- Tcl_Panic("ChildObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclChildObjCmd: interpreter has been deleted");
}
if (objc < 2) {
@@ -2920,7 +3023,7 @@ ChildRecursionLimit(
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
@@ -3156,7 +3259,7 @@ Tcl_IsSafe(
/*
*----------------------------------------------------------------------
*
- * Tcl_MakeSafe --
+ * TclMakeSafe --
*
* Makes its argument interpreter contain only functionality that is
* defined to be part of Safe Tcl. Unsafe commands are hidden, the env
@@ -3173,7 +3276,7 @@ Tcl_IsSafe(
*/
int
-Tcl_MakeSafe(
+TclMakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
@@ -3190,12 +3293,8 @@ Tcl_MakeSafe(
* Assume these functions all work. [Bug 2895741]
*/
- (void) Tcl_Eval(interp,
- "namespace eval ::tcl {namespace eval mathfunc {}}");
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", parent,
- "::tcl::mathfunc::min", 0, NULL);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", parent,
- "::tcl::mathfunc::max", 0, NULL);
+ (void) Tcl_EvalEx(interp,
+ "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
}
iPtr->flags |= SAFE_INTERP;
@@ -3209,7 +3308,7 @@ Tcl_MakeSafe(
* No env array in a safe interpreter.
*/
- Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
@@ -3225,9 +3324,9 @@ Tcl_MakeSafe(
* nameofexecutable])
*/
- Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tclDefaultLibrary", NULL, TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters do
@@ -3517,9 +3616,6 @@ Tcl_LimitAddHandler(
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
- if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) {
- deleteProc = NULL;
- }
/*
* Allocate a handler record.
@@ -4156,7 +4252,7 @@ DeleteScriptLimitCallback(
static void
CallScriptLimitCallback(
ClientData clientData,
- Tcl_Interp *interp) /* Interpreter which failed the limit */
+ TCL_UNUSED(Tcl_Interp *))
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
int code;
@@ -4437,12 +4533,12 @@ ChildCommandLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
} else {
Tcl_Obj *empty;
@@ -4470,13 +4566,13 @@ ChildCommandLimitCmd(
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
- Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
}
break;
}
@@ -4497,7 +4593,7 @@ ChildCommandLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(scriptObj, &scriptLen);
+ (void) TclGetStringFromObj(scriptObj, &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4514,7 +4610,7 @@ ChildCommandLimitCmd(
break;
case OPT_VAL:
limitObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
+ (void) TclGetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
@@ -4624,7 +4720,7 @@ ChildTimeLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
@@ -4632,9 +4728,9 @@ ChildTimeLimitCmd(
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
- Tcl_NewLongObj(limitMoment.sec));
+ Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
@@ -4664,7 +4760,7 @@ ChildTimeLimitCmd(
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
@@ -4673,7 +4769,7 @@ ChildTimeLimitCmd(
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp,
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
@@ -4695,7 +4791,7 @@ ChildTimeLimitCmd(
Tcl_Obj *milliObj = NULL, *secObj = NULL;
int gran = 0;
Tcl_Time limitMoment;
- int tmp;
+ Tcl_WideInt tmp;
Tcl_LimitGetTime(childInterp, &limitMoment);
for (i=consumedObjc ; i<objc ; i+=2) {
@@ -4706,7 +4802,7 @@ ChildTimeLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
+ (void) TclGetStringFromObj(objv[i+1], &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4723,49 +4819,41 @@ ChildTimeLimitCmd(
break;
case OPT_MILLI:
milliObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
+ (void) TclGetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
- if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
- if (tmp < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "milliseconds must be at least 0", -1));
+ if (tmp < 0 || tmp > LONG_MAX) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "milliseconds must be between 0 and %ld", LONG_MAX));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
- limitMoment.usec = ((long) tmp)*1000;
+ limitMoment.usec = ((long)tmp)*1000;
break;
- case OPT_SEC: {
- Tcl_WideInt sec;
+ case OPT_SEC:
secObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
+ (void) TclGetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
- if (TclGetWideIntFromObj(interp, objv[i+1], &sec) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
- if (sec > LONG_MAX) {
+ if (tmp < 0 || tmp > LONG_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seconds must be between 0 and %ld", LONG_MAX));
- goto badValue;
- }
- if (sec < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "seconds must be at least 0", -1));
- badValue:
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
- limitMoment.sec = sec;
+ limitMoment.sec = (long)tmp;
break;
}
- }
}
if (milliObj != NULL || secObj != NULL) {
if (milliObj != NULL) {
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 4850d02..f478a00 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -6,14 +6,18 @@
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2008 Rene Zaumseil
+ * Copyright © 2019 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 "tclTomMath.h"
+#include <math.h>
/*
* For each linked variable there is a data structure of the following type,
@@ -28,7 +32,12 @@ typedef struct Link {
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
- char *addr; /* Location of C variable. */
+ void *addr; /* Location of C variable. */
+ int bytes; /* Size of C variable array. This is 0 when
+ * single variables, and >0 used for array
+ * variables. */
+ int numElems; /* Number of elements in C variable array.
+ * Zero for single variables. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
char c;
@@ -37,12 +46,27 @@ typedef struct Link {
unsigned int ui;
short s;
unsigned short us;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
long l;
unsigned long ul;
+#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
double d;
+ void *aryPtr; /* Generic array. */
+ char *cPtr; /* char array */
+ unsigned char *ucPtr; /* unsigned char array */
+ short *sPtr; /* short array */
+ unsigned short *usPtr; /* unsigned short array */
+ int *iPtr; /* int array */
+ unsigned int *uiPtr; /* unsigned int array */
+ long *lPtr; /* long array */
+ unsigned long *ulPtr; /* unsigned long array */
+ Tcl_WideInt *wPtr; /* wide (long long) array */
+ Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */
+ float *fPtr; /* float array */
+ double *dPtr; /* double array */
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below for
@@ -56,21 +80,42 @@ typedef struct Link {
* LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is
* in progress for this variable, so trace
* callbacks on the variable should be ignored.
+ * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the
+ * heap.
+ * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on
+ * the heap.
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
+#define LINK_ALLOC_ADDR 4
+#define LINK_ALLOC_LAST 8
/*
* Forward references to functions defined later in this file:
*/
-static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
+static char * LinkTraceProc(void *clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
+static void LinkFree(Link *linkPtr);
static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
-static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
-static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
+static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+ double *doublePtr);
+static int SetInvalidRealFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+
+/*
+ * A marker type used to flag weirdnesses so we can pass them around right.
+ */
+
+static Tcl_ObjType invalidRealType = {
+ "invalidReal", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -107,7 +152,7 @@ int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
- char *addr, /* Address of a C variable to be linked to
+ void *addr, /* Address of a C variable to be linked to
* varName. */
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
@@ -119,30 +164,40 @@ Tcl_LinkVar(
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
- TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
+ TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
- linkPtr = ckalloc(sizeof(Link));
+ linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
+ linkPtr->bytes = 0;
+ linkPtr->numElems = 0;
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
return TCL_ERROR;
}
@@ -155,8 +210,196 @@ Tcl_LinkVar(
LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
- TclNsDecrRefCount(linkPtr->nsPtr);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LinkArray --
+ *
+ * Link a C variable array to a Tcl variable so that changes to either
+ * one causes the other to change.
+ *
+ * Results:
+ * The return value is TCL_OK if everything went well or TCL_ERROR if an
+ * error occurred (the interp's result is also set after errors).
+ *
+ * Side effects:
+ * The value at *addr is linked to the Tcl variable "varName", using
+ * "type" to convert between string values for Tcl and binary values for
+ * *addr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LinkArray(
+ Tcl_Interp *interp, /* Interpreter in which varName exists. */
+ const char *varName, /* Name of a global variable in interp. */
+ void *addr, /* Address of a C variable to be linked to
+ * varName. If NULL then the necessary space
+ * will be allocated and returned as the
+ * interpreter result. */
+ int type, /* Type of C variable: TCL_LINK_INT, etc. Also
+ * may have TCL_LINK_READ_ONLY OR'ed in. */
+ int size) /* Size of C variable array, >1 if array */
+{
+ Tcl_Obj *objPtr;
+ Link *linkPtr;
+ Namespace *dummy;
+ const char *name;
+ int code;
+
+ if (size < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong array size given", -1));
+ return TCL_ERROR;
+ }
+
+ linkPtr = (Link *)ckalloc(sizeof(Link));
+ linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
+ linkPtr->numElems = size;
+ if (type & TCL_LINK_READ_ONLY) {
+ linkPtr->flags = LINK_READ_ONLY;
+ } else {
+ linkPtr->flags = 0;
+ }
+
+ switch (linkPtr->type) {
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ linkPtr->bytes = size * sizeof(int);
+ break;
+ case TCL_LINK_DOUBLE:
+ linkPtr->bytes = size * sizeof(double);
+ break;
+ case TCL_LINK_WIDE_INT:
+ linkPtr->bytes = size * sizeof(Tcl_WideInt);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ linkPtr->bytes = size * sizeof(Tcl_WideUInt);
+ break;
+ case TCL_LINK_CHAR:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ case TCL_LINK_UCHAR:
+ linkPtr->bytes = size * sizeof(unsigned char);
+ break;
+ case TCL_LINK_SHORT:
+ linkPtr->bytes = size * sizeof(short);
+ break;
+ case TCL_LINK_USHORT:
+ linkPtr->bytes = size * sizeof(unsigned short);
+ break;
+ case TCL_LINK_UINT:
+ linkPtr->bytes = size * sizeof(unsigned int);
+ break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
+ case TCL_LINK_LONG:
+ linkPtr->bytes = size * sizeof(long);
+ break;
+ case TCL_LINK_ULONG:
+ linkPtr->bytes = size * sizeof(unsigned long);
+ break;
+#endif
+ case TCL_LINK_FLOAT:
+ linkPtr->bytes = size * sizeof(float);
+ break;
+ case TCL_LINK_STRING:
+ linkPtr->bytes = size * sizeof(char);
+ size = 1; /* This is a variable length string, no need
+ * to check last value. */
+
+ /*
+ * If no address is given create one and use as address the
+ * not needed linkPtr->lastValue
+ */
+
+ if (addr == NULL) {
+ linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ addr = (char *) &linkPtr->lastValue.cPtr;
+ }
+ break;
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ default:
+ LinkFree(linkPtr);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad linked array variable type", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate C variable space in case no address is given
+ */
+
+ if (addr == NULL) {
+ linkPtr->addr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_ADDR;
+ } else {
+ linkPtr->addr = addr;
+ }
+
+ /*
+ * If necessary create space for last used value.
+ */
+
+ if (size > 1) {
+ linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ }
+
+ /*
+ * Initialize allocated space.
+ */
+
+ if (linkPtr->flags & LINK_ALLOC_ADDR) {
+ memset(linkPtr->addr, 0, linkPtr->bytes);
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes);
+ }
+
+ /*
+ * Set common structure values.
+ */
+
+ linkPtr->interp = interp;
+ linkPtr->varName = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(linkPtr->varName);
+
+ TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+ &(linkPtr->nsPtr), &dummy, &dummy, &name);
+ linkPtr->nsPtr->refCount++;
+
+ objPtr = ObjValue(linkPtr);
+ if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
+ TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(linkPtr->varName);
+ LinkFree(linkPtr);
+ return TCL_ERROR;
+ }
+
+ code = Tcl_TraceVar2(interp, varName, NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ LinkTraceProc, linkPtr);
+ if (code != TCL_OK) {
+ Tcl_DecrRefCount(linkPtr->varName);
+ LinkFree(linkPtr);
}
return code;
}
@@ -194,10 +437,7 @@ Tcl_UnlinkVar(
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- if (linkPtr->nsPtr) {
- TclNsDecrRefCount(linkPtr->nsPtr);
- }
- ckfree(linkPtr);
+ LinkFree(linkPtr);
}
/*
@@ -248,6 +488,201 @@ Tcl_UpdateLinkedVar(
/*
*----------------------------------------------------------------------
*
+ * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial --
+ *
+ * Helper functions for LinkTraceProc and ObjValue. These are all
+ * factored out here to make those functions simpler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetInt(
+ Tcl_Obj *objPtr,
+ int *intPtr)
+{
+ return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
+ && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
+}
+
+static inline int
+GetWide(
+ Tcl_Obj *objPtr,
+ Tcl_WideInt *widePtr)
+{
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return 1;
+ }
+ *widePtr = intValue;
+ }
+ return 0;
+}
+
+static inline int
+GetUWide(
+ Tcl_Obj *objPtr,
+ Tcl_WideUInt *uwidePtr)
+{
+ if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) {
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return 1;
+ }
+ *uwidePtr = intValue;
+ }
+ return 0;
+}
+
+static inline int
+GetDouble(
+ Tcl_Obj *objPtr,
+ double *dblPtr)
+{
+ if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
+ return 0;
+ } else {
+#ifdef ACCEPT_NAN
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);
+
+ if (irPtr != NULL) {
+ *dblPtr = irPtr->doubleValue;
+ return 0;
+ }
+#endif /* ACCEPT_NAN */
+ return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
+ }
+}
+
+static inline int
+EqualDouble(
+ double a,
+ double b)
+{
+ return (a == b)
+#ifdef ACCEPT_NAN
+ || (isnan(a) && isnan(b))
+#endif /* ACCEPT_NAN */
+ ;
+}
+
+static inline int
+IsSpecial(
+ double a)
+{
+ return isinf(a)
+#ifdef ACCEPT_NAN
+ || isnan(a)
+#endif /* ACCEPT_NAN */
+ ;
+}
+
+/*
+ * Mark an object as holding a weird double.
+ */
+
+static int
+SetInvalidRealFromAny(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *objPtr)
+{
+ const char *str;
+ const char *endPtr;
+ int length;
+
+ str = TclGetStringFromObj(objPtr, &length);
+ if ((length == 1) && (str[0] == '.')) {
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = 0.0;
+ return TCL_OK;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
+ TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
+ /*
+ * If number is followed by [eE][+-]?, then it is an invalid
+ * double, but it could be the start of a valid double.
+ */
+
+ if (*endPtr == 'e' || *endPtr == 'E') {
+ ++endPtr;
+ if (*endPtr == '+' || *endPtr == '-') {
+ ++endPtr;
+ }
+ if (*endPtr == 0) {
+ double doubleValue = 0.0;
+
+ Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+ TclFreeInternalRep(objPtr);
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = doubleValue;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * This function checks for integer representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
+ * (upperand lowercase). See bug [39f6304c2e].
+ */
+
+static int
+GetInvalidIntFromObj(
+ Tcl_Obj *objPtr,
+ int *intPtr)
+{
+ int length;
+ const char *str = TclGetStringFromObj(objPtr, &length);
+
+ if ((length == 0) || ((length == 2) && (str[0] == '0')
+ && strchr("xXbBoOdD", str[1]))) {
+ *intPtr = 0;
+ return TCL_OK;
+ } else if ((length == 1) && strchr("+-", str[0])) {
+ *intPtr = (str[0] == '+');
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * This function checks for double representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
+ */
+
+static int
+GetInvalidDoubleFromObj(
+ Tcl_Obj *objPtr,
+ double *doublePtr)
+{
+ int intValue;
+
+ if (TclHasInternalRep(objPtr, &invalidRealType)) {
+ goto gotdouble;
+ }
+ if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
+ *doublePtr = (double) intValue;
+ return TCL_OK;
+ }
+ if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
+ gotdouble:
+ *doublePtr = objPtr->internalRep.doubleValue;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
@@ -268,21 +703,28 @@ Tcl_UpdateLinkedVar(
static char *
LinkTraceProc(
- ClientData clientData, /* Contains information about the link. */
+ void *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. */
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ /* Links can only be made to global variables,
+ * so we can find them with need to resolve
+ * caller-supplied name in caller context. */
int flags) /* Miscellaneous additional information. */
{
- Link *linkPtr = clientData;
+ Link *linkPtr = (Link *)clientData;
int changed;
- size_t valueLength;
+ int valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
+ Tcl_WideUInt valueUWide;
double valueDouble;
+ int objc;
+ Tcl_Obj **objv;
+ int i;
/*
* If the variable is being unset, then just re-create it (with a trace)
@@ -292,10 +734,7 @@ LinkTraceProc(
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
- if (linkPtr->nsPtr) {
- TclNsDecrRefCount(linkPtr->nsPtr);
- }
- ckfree(linkPtr);
+ LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -322,49 +761,64 @@ LinkTraceProc(
*/
if (flags & TCL_TRACE_READS) {
- switch (linkPtr->type) {
- case TCL_LINK_INT:
- case TCL_LINK_BOOLEAN:
- changed = (LinkedVar(int) != linkPtr->lastValue.i);
- break;
- case TCL_LINK_DOUBLE:
- changed = (LinkedVar(double) != linkPtr->lastValue.d);
- break;
- case TCL_LINK_WIDE_INT:
- changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
- break;
- case TCL_LINK_WIDE_UINT:
- changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
- break;
- case TCL_LINK_CHAR:
- changed = (LinkedVar(char) != linkPtr->lastValue.c);
- break;
- case TCL_LINK_UCHAR:
- changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
- break;
- case TCL_LINK_SHORT:
- changed = (LinkedVar(short) != linkPtr->lastValue.s);
- break;
- case TCL_LINK_USHORT:
- changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
- break;
- case TCL_LINK_UINT:
- changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
- break;
- case TCL_LINK_LONG:
- changed = (LinkedVar(long) != linkPtr->lastValue.l);
- break;
- case TCL_LINK_ULONG:
- changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
- break;
- case TCL_LINK_FLOAT:
- changed = (LinkedVar(float) != linkPtr->lastValue.f);
- break;
- case TCL_LINK_STRING:
- changed = 1;
- break;
- default:
- return (char *) "internal error: bad linked variable type";
+ /*
+ * Variable arrays
+ */
+
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
+ linkPtr->bytes);
+ } else {
+ /* single variables */
+ switch (linkPtr->type) {
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ changed = (LinkedVar(int) != linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_DOUBLE:
+ changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d);
+ break;
+ case TCL_LINK_WIDE_INT:
+ changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
+ break;
+ case TCL_LINK_CHAR:
+ changed = (LinkedVar(char) != linkPtr->lastValue.c);
+ break;
+ case TCL_LINK_UCHAR:
+ changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
+ break;
+ case TCL_LINK_SHORT:
+ changed = (LinkedVar(short) != linkPtr->lastValue.s);
+ break;
+ case TCL_LINK_USHORT:
+ changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
+ break;
+ case TCL_LINK_UINT:
+ changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
+ break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
+ case TCL_LINK_LONG:
+ changed = (LinkedVar(long) != linkPtr->lastValue.l);
+ break;
+ case TCL_LINK_ULONG:
+ changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
+ break;
+#endif
+ case TCL_LINK_FLOAT:
+ changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f);
+ break;
+ case TCL_LINK_STRING:
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
+ changed = 1;
+ break;
+ default:
+ changed = 0;
+ /* return (char *) "internal error: bad linked variable type"; */
+ }
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -396,167 +850,377 @@ LinkTraceProc(
return (char *) "internal error: linked variable couldn't be read";
}
+ /*
+ * Special cases.
+ */
+
+ switch (linkPtr->type) {
+ case TCL_LINK_STRING:
+ value = TclGetStringFromObj(valueObj, &valueLength);
+ valueLength++; /* include end of string char */
+ pp = (char **) linkPtr->addr;
+
+ *pp = (char *)ckrealloc(*pp, valueLength);
+ memcpy(*pp, value, valueLength);
+ return NULL;
+
+ case TCL_LINK_CHARS:
+ value = (char *) TclGetStringFromObj(valueObj, &valueLength);
+ valueLength++; /* include end of string char */
+ if (valueLength > linkPtr->bytes) {
+ return (char *) "wrong size of char* value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
+ memcpy(linkPtr->addr, value, valueLength);
+ } else {
+ linkPtr->lastValue.c = '\0';
+ LinkedVar(char) = linkPtr->lastValue.c;
+ }
+ return NULL;
+
+ case TCL_LINK_BINARY:
+ value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
+ if (valueLength != linkPtr->bytes) {
+ return (char *) "wrong size of binary value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
+ memcpy(linkPtr->addr, value, valueLength);
+ } else {
+ linkPtr->lastValue.uc = (unsigned char) *value;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ }
+ return NULL;
+ }
+
+ /*
+ * A helper macro. Writing this as a function is messy because of type
+ * variance.
+ */
+
+#define InRange(lowerLimit, value, upperLimit) \
+ ((value) >= (lowerLimit) && (value) <= (upperLimit))
+
+ /*
+ * If we're working with an array of numbers, extract the Tcl list.
+ */
+
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (TclListObjGetElementsM(NULL, (valueObj), &objc, &objv) == TCL_ERROR
+ || objc != linkPtr->numElems) {
+ return (char *) "wrong dimension";
+ }
+ }
+
switch (linkPtr->type) {
case TCL_LINK_INT:
- if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ int *varPtr = &linkPtr->lastValue.iPtr[i];
+
+ if (GetInt(objv[i], varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have integer values";
+ }
+ }
+ } else {
+ int *varPtr = &linkPtr->lastValue.i;
+
+ if (GetInt(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have integer value";
+ }
+ LinkedVar(int) = *varPtr;
}
- LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i];
+
+ if (GetWide(objv[i], varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have wide integer value";
+ }
+ }
+ } else {
+ Tcl_WideInt *varPtr = &linkPtr->lastValue.w;
+
+ if (GetWide(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have wide integer value";
+ }
+ LinkedVar(Tcl_WideInt) = *varPtr;
}
- LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
-#ifdef ACCEPT_NAN
- if (valueObj->typePtr != &tclDoubleType) {
-#endif
- if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have real value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have real value";
}
-#ifdef ACCEPT_NAN
}
- linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
-#endif
+ } else {
+ double *varPtr = &linkPtr->lastValue.d;
+
+ if (GetDouble(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have real value";
+ }
+ LinkedVar(double) = *varPtr;
}
- LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have boolean value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ int *varPtr = &linkPtr->lastValue.iPtr[i];
+
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have boolean value";
+ }
+ }
+ } else {
+ int *varPtr = &linkPtr->lastValue.i;
+
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have boolean value";
+ }
+ LinkedVar(int) = *varPtr;
}
- LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_CHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have char value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have char value";
+ }
+ linkPtr->lastValue.cPtr[i] = (char) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have char value";
+ }
+ LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
- LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
break;
case TCL_LINK_UCHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > UCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned char value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(0, valueInt, (int)UCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned char value";
+ }
+ linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(0, valueInt, (int)UCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned char value";
+ }
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc =
+ (unsigned char) valueInt;
}
- LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
break;
case TCL_LINK_SHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have short value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have short value";
+ }
+ linkPtr->lastValue.sPtr[i] = (short) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have short value";
+ }
+ LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
}
- LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
break;
case TCL_LINK_USHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > USHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned short value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(0, valueInt, (int)USHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned short value";
+ }
+ linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(0, valueInt, (int)USHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned short value";
+ }
+ LinkedVar(unsigned short) = linkPtr->lastValue.us =
+ (unsigned short) valueInt;
}
- LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
break;
case TCL_LINK_UINT:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || valueWide > UINT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned int value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetWide(objv[i], &valueWide)
+ || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned int value";
+ }
+ linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide;
+ }
+ } else {
+ if (GetWide(valueObj, &valueWide)
+ || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned int value";
+ }
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui =
+ (unsigned int) valueWide;
}
- LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < LONG_MIN || valueWide > LONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have long value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetWide(objv[i], &valueWide)
+ || !InRange(LONG_MIN, valueWide, LONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have long value";
+ }
+ linkPtr->lastValue.lPtr[i] = (long) valueWide;
+ }
+ } else {
+ if (GetWide(valueObj, &valueWide)
+ || !InRange(LONG_MIN, valueWide, LONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have long value";
+ }
+ LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide;
}
- LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
break;
case TCL_LINK_ULONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned long value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetUWide(objv[i], &valueUWide)
+ || (valueUWide > ULONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned long value";
+ }
+ linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
+ }
+ } else {
+ if (GetUWide(valueObj, &valueUWide)
+ || (valueUWide > ULONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned long value";
+ }
+ LinkedVar(unsigned long) = linkPtr->lastValue.ul =
+ (unsigned long) valueUWide;
}
- LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
break;
+#endif
case TCL_LINK_WIDE_UINT:
- /*
- * FIXME: represent as a bignum.
- */
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned wide int value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetUWide(objv[i], &valueUWide)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned wide int value";
+ }
+ linkPtr->lastValue.uwPtr[i] = valueUWide;
+ }
+ } else {
+ if (GetUWide(valueObj, &valueUWide)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned wide int value";
+ }
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
- LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
break;
case TCL_LINK_FLOAT:
- if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
- && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
- || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have float value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetDouble(objv[i], &valueDouble)
+ && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
+ && !IsSpecial(valueDouble)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have float value";
+ }
+ linkPtr->lastValue.fPtr[i] = (float) valueDouble;
+ }
+ } else {
+ if (GetDouble(valueObj, &valueDouble)
+ && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
+ && !IsSpecial(valueDouble)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have float value";
+ }
+ LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
}
- LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
- break;
-
- case TCL_LINK_STRING:
- value = TclGetString(valueObj);
- valueLength = valueObj->length + 1;
- pp = (char **) linkPtr->addr;
-
- *pp = ckrealloc(*pp, valueLength);
- memcpy(*pp, value, valueLength);
break;
default:
return (char *) "internal error: bad linked variable type";
}
+
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
+ }
return NULL;
}
@@ -583,51 +1247,185 @@ ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
- Tcl_Obj *resultObj;
+ Tcl_Obj *resultObj, **objv;
+ int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewIntObj(linkPtr->lastValue.i);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewDoubleObj(objv[i], linkPtr->lastValue.dPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.c = LinkedVar(char);
- return Tcl_NewIntObj(linkPtr->lastValue.c);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.uc = LinkedVar(unsigned char);
- return Tcl_NewIntObj(linkPtr->lastValue.uc);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.s = LinkedVar(short);
- return Tcl_NewIntObj(linkPtr->lastValue.s);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.us = LinkedVar(unsigned short);
- return Tcl_NewIntObj(linkPtr->lastValue.us);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
+#endif
case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
- case TCL_LINK_WIDE_UINT:
+ case TCL_LINK_WIDE_UINT: {
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
- /*
- * FIXME: represent as a bignum.
- */
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
+ Tcl_Obj *uwObj;
+ TclNewUIntObj(uwObj, linkPtr->lastValue.uw);
+ return uwObj;
+ }
+
case TCL_LINK_STRING:
p = LinkedVar(char *);
if (p == NULL) {
@@ -636,6 +1434,25 @@ ObjValue(
}
return Tcl_NewStringObj(p, -1);
+ case TCL_LINK_CHARS:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0';
+ /* take care of proper string end */
+ return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes);
+ }
+ linkPtr->lastValue.c = '\0';
+ return Tcl_NewStringObj(&linkPtr->lastValue.c, 1);
+
+ case TCL_LINK_BINARY:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr,
+ linkPtr->bytes);
+ }
+ linkPtr->lastValue.uc = LinkedVar(unsigned char);
+ return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1);
+
/*
* This code only gets executed if the link type is unknown (shouldn't
* ever happen).
@@ -646,110 +1463,37 @@ ObjValue(
return resultObj;
}
}
-
-static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-
-static Tcl_ObjType invalidRealType = {
- "invalidReal", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- NULL /* setFromAnyProc */
-};
-
-static int
-SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
- int length;
- const char *str;
- const char *endPtr;
-
- str = TclGetStringFromObj(objPtr, &length);
- if ((length == 1) && (str[0] == '.')){
- objPtr->typePtr = &invalidRealType;
- objPtr->internalRep.doubleValue = 0.0;
- return TCL_OK;
- }
- if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
- TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
- /* If number is followed by [eE][+-]?, then it is an invalid
- * double, but it could be the start of a valid double. */
- if (*endPtr == 'e' || *endPtr == 'E') {
- ++endPtr;
- if (*endPtr == '+' || *endPtr == '-') ++endPtr;
- if (*endPtr == 0) {
- double doubleValue = 0.0;
- Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
- if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->typePtr = &invalidRealType;
- objPtr->internalRep.doubleValue = doubleValue;
- return TCL_OK;
- }
- }
- }
- return TCL_ERROR;
-}
-
-
+
/*
- * This function checks for integer representations, which are valid
- * when linking with C variables, but which are invalid in other
- * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o"
- * (upperand lowercase). See bug [39f6304c2e].
+ *----------------------------------------------------------------------
+ *
+ * LinkFree --
+ *
+ * Free's allocated space of given link and link structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
*/
-int
-GetInvalidIntFromObj(Tcl_Obj *objPtr,
- int *intPtr)
-{
- const char *str = TclGetString(objPtr);
-
- if ((objPtr->length == 0) ||
- ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) {
- *intPtr = 0;
- return TCL_OK;
- } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
- *intPtr = (str[0] == '+');
- return TCL_OK;
- }
- return TCL_ERROR;
-}
-
-int
-GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
-{
- int intValue;
-
- if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
- return TCL_ERROR;
- }
- *widePtr = intValue;
- return TCL_OK;
-}
-/*
- * This function checks for double representations, which are valid
- * when linking with C variables, but which are invalid in other
- * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
- * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
- */
-int
-GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
- double *doublePtr)
+static void
+LinkFree(
+ Link *linkPtr) /* Structure describing linked variable. */
{
- int intValue;
-
- if (objPtr->typePtr == &invalidRealType) {
- goto gotdouble;
+ if (linkPtr->nsPtr) {
+ TclNsDecrRefCount(linkPtr->nsPtr);
}
- if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
- *doublePtr = (double) intValue;
- return TCL_OK;
+ if (linkPtr->flags & LINK_ALLOC_ADDR) {
+ ckfree(linkPtr->addr);
}
- if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
- gotdouble:
- *doublePtr = objPtr->internalRep.doubleValue;
- return TCL_OK;
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ ckfree(linkPtr->lastValue.aryPtr);
}
- return TCL_ERROR;
+ ckfree((char *) linkPtr);
}
/*
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index a994fd7..3f17e90 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -3,39 +3,152 @@
*
* This file contains functions that implement the Tcl list object type.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 2022 Ashok P. Nadkarni. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <assert.h>
#include "tclInt.h"
+#include "tclTomMath.h"
+#include "tclArithSeries.h"
/*
- * Prototypes for functions defined later in this file:
+ * TODO - memmove is fast. Measure at what size we should prefer memmove
+ * (for unshared objects only) in lieu of range operations. On the other
+ * hand, more cache dirtied?
*/
-static List * AttemptNewList(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static List * NewListInternalRep(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);
-static void UpdateStringOfList(Tcl_Obj *listPtr);
+/*
+ * Macros for validation and bug checking.
+ */
+
+/*
+ * Control whether asserts are enabled. Always enable in debug builds. In non-debug
+ * builds, can be set with cdebug="-DENABLE_LIST_ASSERTS" on the nmake command line.
+ */
+#ifdef ENABLE_LIST_ASSERTS
+# ifdef NDEBUG
+# undef NDEBUG /* Activate assert() macro */
+# endif
+#else
+# ifndef NDEBUG
+# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */
+# endif
+#endif
+
+#ifdef ENABLE_LIST_ASSERTS
+
+#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */
+/*
+ * LIST_INDEX_ASSERT is to catch errors with negative indices and counts
+ * being passed AFTER validation. On Tcl9 length types are unsigned hence
+ * the checks against LIST_MAX. On Tcl8 length types are signed hence the
+ * also checks against 0.
+ */
+#define LIST_INDEX_ASSERT(idxarg_) \
+ do { \
+ Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \
+ } while (0)
+/* Ditto for counts except upper limit is different */
+#define LIST_COUNT_ASSERT(countarg_) \
+ do { \
+ Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \
+ } while (0)
+
+#else
+
+#define LIST_ASSERT(cond_) ((void) 0)
+#define LIST_INDEX_ASSERT(idx_) ((void) 0)
+#define LIST_COUNT_ASSERT(count_) ((void) 0)
+
+#endif
+
+/* Checks for when caller should have already converted to internal list type */
+#define LIST_ASSERT_TYPE(listObj_) \
+ LIST_ASSERT((listObj_)->typePtr == &tclListType);
+
+
+/*
+ * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
+ * command line), the entire list internal representation is checked for
+ * inconsistencies. This has a non-trivial cost so has to be separately
+ * enabled and not part of assertions checking. However, the test suite does
+ * invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS.
+ */
+#ifdef ENABLE_LIST_INVARIANTS
+#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_, __FILE__, __LINE__)
+#else
+#define LISTREP_CHECK(listRepPtr_) (void) 0
+#endif
+
+/*
+ * Flags used for controlling behavior of allocation of list
+ * internal representations.
+ *
+ * If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if
+ * list is too large or memory cannot be allocated. Without the flag
+ * a NULL pointer is returned.
+ *
+ * The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT,
+ * LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to
+ * control additional space when allocating.
+ * - If none of these flags is present, the exact space requested is
+ * allocated, nothing more.
+ * - Otherwise, if only LISTREP_FAVOR_FRONT is present, extra space is
+ * allocated with more towards the front.
+ * - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated
+ * with more to the back.
+ * - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space
+ * is equally apportioned.
+ * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at
+ * the back.
+ */
+#define LISTREP_PANIC_ON_FAIL 0x00000001
+#define LISTREP_SPACE_FAVOR_FRONT 0x00000002
+#define LISTREP_SPACE_FAVOR_BACK 0x00000004
+#define LISTREP_SPACE_ONLY_BACK 0x00000008
+#define LISTREP_SPACE_FAVOR_NONE \
+ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
+#define LISTREP_SPACE_FLAGS \
+ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
+ | LISTREP_SPACE_ONLY_BACK)
+
+/*
+ * Prototypes for non-inline static functions defined later in this file:
+ */
+static int MemoryAllocationError(Tcl_Interp *, size_t size);
+static int ListLimitExceededError(Tcl_Interp *);
+static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags);
+static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *);
+static int ListRepInitAttempt(Tcl_Interp *,
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ ListRep *);
+static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);
+static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
+static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr);
+static void ListRepRange(ListRep *srcRepPtr,
+ Tcl_Size rangeStart,
+ Tcl_Size rangeEnd,
+ int preserveSrcRep,
+ ListRep *rangeRepPtr);
+static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots);
+static void ListRepValidate(const ListRep *repPtr, const char *file,
+ int lineNum);
+static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeListInternalRep(Tcl_Obj *listPtr);
+static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfList(Tcl_Obj *listPtr);
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
*
- * The internal representation of a list object is a two-pointer
- * representation. The first pointer designates a List structure that contains
- * an array of pointers to the element objects, together with integers that
- * represent the current element count and the allocated size of the array.
- * The second pointer is normally NULL; during execution of functions in this
- * file that operate on nested sublists, it is occasionally used as working
- * storage to avoid an auxiliary stack.
+ * The internal representation of a list object is ListRep defined in tcl.h.
*/
const Tcl_ObjType tclListType = {
@@ -47,130 +160,905 @@ const Tcl_ObjType tclListType = {
};
/* Macros to manipulate the List internal rep */
+#define ListRepIncrRefs(repPtr_) \
+ do { \
+ (repPtr_)->storePtr->refCount++; \
+ if ((repPtr_)->spanPtr) \
+ (repPtr_)->spanPtr->refCount++; \
+ } while (0)
-#define ListSetInternalRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
+/* Returns number of free unused slots at the back of the ListRep's ListStore */
+#define ListRepNumFreeTail(repPtr_) \
+ ((repPtr_)->storePtr->numAllocated \
+ - ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed))
+/* Returns number of free unused slots at the front of the ListRep's ListStore */
+#define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed)
-#ifndef TCL_MIN_ELEMENT_GROWTH
-#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
-#endif
+/* Returns a pointer to the slot corresponding to list index listIdx_ */
+#define ListRepSlotPtr(repPtr_, listIdx_) \
+ (&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)])
+
+/*
+ * Macros to replace the internal representation in a Tcl_Obj. There are
+ * subtle differences in each so make sure to use the right one to avoid
+ * memory leaks, access to freed memory and the like.
+ *
+ * ListObjStompRep - assumes the Tcl_Obj internal representation can be
+ * overwritten AND that the passed ListRep already has reference counts that
+ * include the reference from the Tcl_Obj. Basically just copies the pointers
+ * and sets the internal Tcl_Obj type to list
+ *
+ * ListObjOverwriteRep - like ListObjOverwriteRep but additionally
+ * increments reference counts on the passed ListRep. Generally used when
+ * the string representation of the Tcl_Obj is not to be modified.
+ *
+ * ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally
+ * assumes the Tcl_Obj internal rep is valid (and possibly even same as
+ * passed ListRep) and frees it first. Additionally invalidates the string
+ * representation. Generally used when modifying a Tcl_Obj value.
+ */
+#define ListObjStompRep(objPtr_, repPtr_) \
+ do { \
+ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
+ (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
+ (objPtr_)->typePtr = &tclListType; \
+ } while (0)
+
+#define ListObjOverwriteRep(objPtr_, repPtr_) \
+ do { \
+ ListRepIncrRefs(repPtr_); \
+ ListObjStompRep(objPtr_, repPtr_); \
+ } while (0)
+
+#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \
+ do { \
+ /* Note order important, don't use ListObjOverwriteRep! */ \
+ ListRepIncrRefs(repPtr_); \
+ TclFreeInternalRep(objPtr_); \
+ TclInvalidateStringRep(objPtr_); \
+ ListObjStompRep(objPtr_, repPtr_); \
+ } while (0)
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
+ *
+ * ListSpanNew --
+ *
+ * Allocates and initializes memory for a new ListSpan. The reference
+ * count on the returned struct is 0.
+ *
+ * Results:
+ * Non-NULL pointer to the allocated ListSpan.
+ *
+ * Side effects:
+ * The function will panic on memory allocation failure.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline ListSpan *
+ListSpanNew(
+ Tcl_Size firstSlot, /* Starting slot index of the span */
+ Tcl_Size numSlots) /* Number of slots covered by the span */
+{
+ ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr));
+ spanPtr->refCount = 0;
+ spanPtr->spanStart = firstSlot;
+ spanPtr->spanLength = numSlots;
+ return spanPtr;
+}
+
+/*
+ *------------------------------------------------------------------------
*
- * NewListInternalRep --
+ * ListSpanDecrRefs --
*
- * Creates a 'List' structure with space for 'objc' elements. 'objc' must
- * be > 0. If 'objv' is not NULL, The list is initialized with first
- * 'objc' values in that array. Otherwise the list is initialized to have
- * 0 elements, with space to add 'objc' more. Flag value 'p' indicates
- * how to behave on failure.
+ * Decrements the reference count on a span, freeing the memory if
+ * it drops to zero or less.
*
- * Value
+ * Results:
+ * None.
*
- * A new 'List' structure with refCount 0. If some failure
- * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic'
- * is called if it is not.
+ * Side effects:
+ * The memory may be freed.
*
- * Effect
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListSpanDecrRefs(ListSpan *spanPtr)
+{
+ if (spanPtr->refCount <= 1) {
+ ckfree(spanPtr);
+ } else {
+ spanPtr->refCount -= 1;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
*
- * The refCount of each value in 'objv' is incremented as it is added
- * to the list.
+ * ListSpanMerited --
*
- *----------------------------------------------------------------------
+ * Creation of a new list may sometimes be done as a span on existing
+ * storage instead of allocating new. The tradeoff is that if the
+ * original list is released, the new span-based list may hold on to
+ * more memory than desired. This function implements heuristics for
+ * deciding which option is better.
+ *
+ * Results:
+ * Returns non-0 if a span-based list is likely to be more optimal
+ * and 0 if not.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
*/
+static inline int
+ListSpanMerited(
+ Tcl_Size length, /* Length of the proposed span */
+ Tcl_Size usedStorageLength, /* Number of slots currently in used */
+ Tcl_Size allocatedStorageLength) /* Length of the currently allocation */
+{
+ /*
+ TODO
+ - heuristics thresholds need to be determined
+ - currently, information about the sharing (ref count) of existing
+ storage is not passed. Perhaps it should be. For example if the
+ existing storage has a "large" ref count, then it might make sense
+ to do even a small span.
+ */
-static List *
-NewListInternalRep(
- int objc,
- Tcl_Obj *const objv[],
- int p)
+ if (length < LIST_SPAN_THRESHOLD) {
+ return 0;/* No span for small lists */
+ }
+ if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) {
+ return 0; /* No span if less than 3/8 of allocation */
+ }
+ if (length < usedStorageLength / 2) {
+ return 0; /* No span if less than half current storage */
+ }
+
+ return 1;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListStoreUpSize --
+ *
+ * For reasons of efficiency, extra space is allocated for a ListStore
+ * compared to what was requested. This function calculates how many
+ * slots should actually be allocated for a given request size.
+ *
+ * Results:
+ * Number of slots to allocate.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline Tcl_Size
+ListStoreUpSize(Tcl_Size numSlotsRequested) {
+ /* TODO -how much extra? May be double only for smaller requests? */
+ return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested
+ : LIST_MAX;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepFreeUnreferenced --
+ *
+ * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks
+ * before calling it.
+ *
+ * IMPORTANT: this function must not be called on an internal
+ * representation of a Tcl_Obj that is itself shared.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See comments for ListRepUnsharedFreeUnreferenced.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepFreeUnreferenced(const ListRep *repPtr)
+{
+ if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
+ /* T:listrep-1.5.1 */
+ ListRepUnsharedFreeUnreferenced(repPtr);
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayIncrRefs --
+ *
+ * Increments the reference counts for Tcl_Obj's in a subarray.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * As above.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayIncrRefs(
+ Tcl_Obj * const *objv, /* Pointer to the array */
+ Tcl_Size startIdx, /* Starting index of subarray within objv */
+ Tcl_Size count) /* Number of elements in the subarray */
+{
+ Tcl_Obj * const *end;
+ LIST_INDEX_ASSERT(startIdx);
+ LIST_COUNT_ASSERT(count);
+ objv += startIdx;
+ end = objv + count;
+ while (objv < end) {
+ Tcl_IncrRefCount(*objv);
+ ++objv;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayDecrRefs --
+ *
+ * Decrements the reference counts for Tcl_Obj's in a subarray.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * As above.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayDecrRefs(
+ Tcl_Obj * const *objv, /* Pointer to the array */
+ Tcl_Size startIdx, /* Starting index of subarray within objv */
+ Tcl_Size count) /* Number of elements in the subarray */
{
- List *listRepPtr;
+ Tcl_Obj * const *end;
+ LIST_INDEX_ASSERT(startIdx);
+ LIST_COUNT_ASSERT(count);
+ objv += startIdx;
+ end = objv + count;
+ while (objv < end) {
+ Tcl_DecrRefCount(*objv);
+ ++objv;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayCopy --
+ *
+ * Copies an array of Tcl_Obj* pointers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Reference counts on copied Tcl_Obj's are incremented.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayCopy(
+ Tcl_Obj **to, /* Destination */
+ Tcl_Size count, /* Number of pointers to copy */
+ Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */
+{
+ Tcl_Obj **end;
+ LIST_COUNT_ASSERT(count);
+ end = to + count;
+ /* TODO - would memmove followed by separate IncrRef loop be faster? */
+ while (to < end) {
+ Tcl_IncrRefCount(*from);
+ *to++ = *from++;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * MemoryAllocationError --
+ *
+ * Generates a memory allocation failure error.
+ *
+ * Results:
+ * Always TCL_ERROR.
+ *
+ * Side effects:
+ * Error message and code are stored in the interpreter if not NULL.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+MemoryAllocationError(
+ Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
+ size_t size) /* Size of attempted allocation that failed */
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "list construction failed: unable to alloc %" TCL_LL_MODIFIER
+ "u bytes",
+ (Tcl_WideInt)size));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListLimitExceeded --
+ *
+ * Generates an error for exceeding maximum list size.
+ *
+ * Results:
+ * Always TCL_ERROR.
+ *
+ * Side effects:
+ * Error message and code are stored in the interpreter if not NULL.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+ListLimitExceededError(Tcl_Interp *interp)
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedShiftDown --
+ *
+ * Shifts the "in-use" contents in the ListStore for a ListRep down
+ * by the given number of slots. The ListStore must be unshared and
+ * the free space at the front of the storage area must be big enough.
+ * It is the caller's responsibility to check.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The contents of the ListRep's ListStore area are shifted down in the
+ * storage area. The ListRep's ListSpan is updated accordingly.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount)
+{
+ ListStore *storePtr;
- if (objc <= 0) {
- Tcl_Panic("NewListInternalRep: expects postive element count");
+ LISTREP_CHECK(repPtr);
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+
+ storePtr = repPtr->storePtr;
+
+ LIST_COUNT_ASSERT(shiftCount);
+ LIST_ASSERT(storePtr->firstUsed >= shiftCount);
+
+ memmove(&storePtr->slots[storePtr->firstUsed - shiftCount],
+ &storePtr->slots[storePtr->firstUsed],
+ storePtr->numUsed * sizeof(Tcl_Obj *));
+ storePtr->firstUsed -= shiftCount;
+ if (repPtr->spanPtr) {
+ repPtr->spanPtr->spanStart -= shiftCount;
+ LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed);
+ } else {
+ /*
+ * If there was no span, firstUsed must have been 0 (Invariant)
+ * AND shiftCount must have been 0 (<= firstUsed on call)
+ * In other words, this would have been a no-op
+ */
+
+ LIST_ASSERT(storePtr->firstUsed == 0);
+ LIST_ASSERT(shiftCount == 0);
+ }
+
+ LISTREP_CHECK(repPtr);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedShiftUp --
+ *
+ * Shifts the "in-use" contents in the ListStore for a ListRep up
+ * by the given number of slots. The ListStore must be unshared and
+ * the free space at the back of the storage area must be big enough.
+ * It is the caller's responsibility to check.
+ * TODO - this function is not currently used.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The contents of the ListRep's ListStore area are shifted up in the
+ * storage area. The ListRep's ListSpan is updated accordingly.
+ *
+ *------------------------------------------------------------------------
+ */
+#if 0
+static inline void
+ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount)
+{
+ ListStore *storePtr;
+
+ LISTREP_CHECK(repPtr);
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+ LIST_COUNT_ASSERT(shiftCount);
+
+ storePtr = repPtr->storePtr;
+ LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount)
+ <= storePtr->numAllocated);
+
+ memmove(&storePtr->slots[storePtr->firstUsed + shiftCount],
+ &storePtr->slots[storePtr->firstUsed],
+ storePtr->numUsed * sizeof(Tcl_Obj *));
+ storePtr->firstUsed += shiftCount;
+ if (repPtr->spanPtr) {
+ repPtr->spanPtr->spanStart += shiftCount;
+ } else {
+ /* No span means entire original list is span */
+ /* Should have been zero before shift - Invariant TBD */
+ LIST_ASSERT(storePtr->firstUsed == shiftCount);
+ repPtr->spanPtr = ListSpanNew(shiftCount, storePtr->numUsed);
}
+ LISTREP_CHECK(repPtr);
+}
+#endif
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepValidate --
+ *
+ * Checks all invariants for a ListRep and panics on failure.
+ * Note this is independent of NDEBUG, assert etc.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Panics if any invariant is not met.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRepValidate(const ListRep *repPtr, const char *file, int lineNum)
+{
+ ListStore *storePtr = repPtr->storePtr;
+ const char *condition;
+
+ (void)storePtr; /* To stop gcc from whining about unused vars */
+
+#define INVARIANT(cond_) \
+ do { \
+ if (!(cond_)) { \
+ condition = #cond_; \
+ goto failure; \
+ } \
+ } while (0)
+
+ /* Separate each condition so line number gives exact reason for failure */
+ INVARIANT(storePtr != NULL);
+ INVARIANT(storePtr->numAllocated >= 0);
+ INVARIANT(storePtr->numAllocated <= LIST_MAX);
+ INVARIANT(storePtr->firstUsed >= 0);
+ INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
+ INVARIANT(storePtr->numUsed >= 0);
+ INVARIANT(storePtr->numUsed <= storePtr->numAllocated);
+ INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed));
+
+ if (! ListRepIsShared(repPtr)) {
+ /*
+ * If this is the only reference and there is no span, then store
+ * occupancy must begin at 0
+ */
+ INVARIANT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0);
+ }
+
+ INVARIANT(ListRepStart(repPtr) >= storePtr->firstUsed);
+ INVARIANT(ListRepLength(repPtr) <= storePtr->numUsed);
+ INVARIANT(ListRepStart(repPtr) <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr)));
+
+#undef INVARIANT
+
+ return;
+
+failure:
+ Tcl_Panic("List internal failure in %s line %d. Condition: %s",
+ file,
+ lineNum,
+ condition);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclListObjValidate --
+ *
+ * Wrapper around ListRepValidate. Primarily used from test suite.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Will panic if internal structure is not consistent or if object
+ * cannot be converted to a list object.
+ *
+ *------------------------------------------------------------------------
+ */
+void
+TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
+{
+ ListRep listRep;
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
+ "a list object.");
+ }
+ ListRepValidate(&listRep, __FILE__, __LINE__);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ListStoreNew --
+ *
+ * Allocates a new ListStore with space for at least objc elements. objc
+ * must be > 0. If objv!=NULL, initializes with the first objc values
+ * in that array. If objv==NULL, initalize 0 elements, with space
+ * to add objc more.
+ *
+ * Normally the function allocates the exact space requested unless
+ * the flags arguments has any LISTREP_SPACE_*
+ * bits set. See the comments for those #defines.
+ *
+ * Results:
+ * On success, a pointer to the allocated ListStore is returned.
+ * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in
+ * flags; otherwise returns NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented on success
+ * since the returned ListStore references them.
+ *
+ *----------------------------------------------------------------------
+ */
+static ListStore *
+ListStoreNew(
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ ListStore *storePtr;
+ Tcl_Size capacity;
+
/*
* First check to see if we'd overflow and try to allocate an object
- * larger than our memory allocator allows. Note that this is actually a
- * fairly small value when you're on a serious 64-bit machine, but that
- * requires API changes to fix. See [Bug 219196] for a discussion.
+ * larger than our memory allocator allows.
*/
-
- if ((size_t)objc > LIST_MAX) {
- if (p) {
- Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
- LIST_MAX);
+ if (objc > LIST_MAX) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
+ Tcl_Panic("max length of a Tcl list exceeded");
}
return NULL;
}
- listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
- if (listRepPtr == NULL) {
- if (p) {
+ if (flags & LISTREP_SPACE_FLAGS) {
+ capacity = ListStoreUpSize(objc);
+ } else {
+ capacity = objc;
+ }
+
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ if (storePtr == NULL && capacity != objc) {
+ capacity = objc; /* Try allocating exact size */
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ }
+ if (storePtr == NULL) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
LIST_SIZE(objc));
}
return NULL;
}
- listRepPtr->canonicalFlag = 0;
- listRepPtr->refCount = 0;
- listRepPtr->maxElemCount = objc;
+ storePtr->refCount = 0;
+ storePtr->flags = 0;
+ storePtr->numAllocated = capacity;
+ if (capacity == objc) {
+ storePtr->firstUsed = 0;
+ } else {
+ Tcl_Size extra = capacity - objc;
+ int spaceFlags = flags & LISTREP_SPACE_FLAGS;
+ if (spaceFlags == LISTREP_SPACE_ONLY_BACK) {
+ storePtr->firstUsed = 0;
+ } else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) {
+ /* Leave more space in the front */
+ storePtr->firstUsed =
+ extra - (extra / 4); /* NOT same as 3*extra/4 */
+ } else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) {
+ /* Leave more space in the back */
+ storePtr->firstUsed = extra / 4;
+ } else {
+ /* Apportion equally */
+ storePtr->firstUsed = extra / 2;
+ }
+ }
if (objv) {
- Tcl_Obj **elemPtrs;
- int i;
-
- listRepPtr->elemCount = objc;
- elemPtrs = &listRepPtr->elements;
- for (i = 0; i < objc; i++) {
- elemPtrs[i] = objv[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
+ storePtr->numUsed = objc;
+ ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv);
} else {
- listRepPtr->elemCount = 0;
+ storePtr->numUsed = 0;
+ }
+
+ return storePtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListStoreReallocate --
+ *
+ * Reallocates the memory for a ListStore.
+ *
+ * Results:
+ * Pointer to the ListStore which may be the same as storePtr or pointer
+ * to a new block of memory. On reallocation failure, NULL is returned.
+ *
+ *
+ * Side effects:
+ * The memory pointed to by storePtr is freed if it a new block has to
+ * be returned.
+ *
+ *
+ *------------------------------------------------------------------------
+ */
+ListStore *
+ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots)
+{
+ Tcl_Size newCapacity;
+ ListStore *newStorePtr;
+
+ newCapacity = ListStoreUpSize(numSlots);
+ newStorePtr =
+ (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL) {
+ newCapacity = numSlots;
+ newStorePtr = (ListStore *)attemptckrealloc(storePtr,
+ LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL)
+ return NULL;
}
- return listRepPtr;
+ /* Only the capacity has changed, fix it in the header */
+ newStorePtr->numAllocated = newCapacity;
+ return newStorePtr;
}
/*
*----------------------------------------------------------------------
*
- * AttemptNewList --
+ * ListRepInit --
+ *
+ * Initializes a ListRep to hold a list internal representation
+ * with space for objc elements.
+ *
+ * objc must be > 0. If objv!=NULL, initializes with the first objc
+ * values in that array. If objv==NULL, initalize list internal rep to
+ * have 0 elements, with space to add objc more.
*
- * Like NewListInternalRep, but additionally sets an error message on failure.
+ * Normally the function allocates the exact space requested unless
+ * the flags arguments has one of the LISTREP_SPACE_* bits set.
+ * See the comments for those #defines.
+ *
+ * The reference counts of the ListStore and ListSpan (if present)
+ * pointed to by the initialized repPtr are set to zero.
+ * Caller has to manage them as necessary.
+ *
+ * Results:
+ * On success, TCL_OK is returned with *listRepPtr initialized.
+ * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise
+ * returns TCL_ERROR with *listRepPtr fields set to NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
+static int
+ListRepInit(
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ int flags,
+ ListRep *repPtr
+ )
+{
+ ListStore *storePtr;
-static List *
-AttemptNewList(
+ storePtr = ListStoreNew(objc, objv, flags);
+ if (storePtr) {
+ repPtr->storePtr = storePtr;
+ if (storePtr->firstUsed == 0) {
+ repPtr->spanPtr = NULL;
+ } else {
+ repPtr->spanPtr =
+ ListSpanNew(storePtr->firstUsed, storePtr->numUsed);
+ }
+ return TCL_OK;
+ }
+ /*
+ * Initialize to keep gcc happy at the call site. Else it complains
+ * about possibly uninitialized use.
+ */
+ repPtr->storePtr = NULL;
+ repPtr->spanPtr = NULL;
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ListRepInitAttempt --
+ *
+ * Creates a list internal rep with space for objc elements. See
+ * ListRepInit for requirements for parameters (in particular objc must
+ * be > 0). This function only adds error messages to the interpreter if
+ * not NULL.
+ *
+ * The reference counts of the ListStore and ListSpan (if present)
+ * pointed to by the initialized repPtr are set to zero.
+ * Caller has to manage them as necessary.
+ *
+ * Results:
+ * On success, TCL_OK is returned with *listRepPtr initialized.
+ * On allocation failure, returnes TCL_ERROR with an error message
+ * in the interpreter if non-NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ListRepInitAttempt(
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ ListRep *repPtr)
{
- List *listRepPtr = NewListInternalRep(objc, objv, 0);
+ int result = ListRepInit(objc, objv, 0, repPtr);
- if (interp != NULL && listRepPtr == NULL) {
+ if (result != TCL_OK && interp != NULL) {
if (objc > LIST_MAX) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
+ ListLimitExceededError(interp);
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list creation failed: unable to alloc %u bytes",
- LIST_SIZE(objc)));
+ MemoryAllocationError(interp, LIST_SIZE(objc));
}
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return listRepPtr;
+ return result;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepClone --
+ *
+ * Does a deep clone of an existing ListRep.
+ *
+ * Normally the function allocates the exact space needed unless
+ * the flags arguments has one of the LISTREP_SPACE_* bits set.
+ * See the comments for those #defines.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The toRepPtr location is initialized with the ListStore and ListSpan
+ * (if needed) containing a copy of the list elements in fromRepPtr.
+ * The function will panic if memory cannot be allocated.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags)
+{
+ Tcl_Obj **fromObjs;
+ Tcl_Size numFrom;
+
+ ListRepElements(fromRepPtr, numFrom, fromObjs);
+ ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedFreeUnreferenced --
+ *
+ * Frees any Tcl_Obj's from the "in-use" area of the ListStore for a
+ * ListRep that are not actually references from any lists.
+ *
+ * IMPORTANT: this function must not be called on a shared internal
+ * representation or the internal representation of a shared Tcl_Obj.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The firstUsed and numUsed fields of the ListStore are updated to
+ * reflect the new "in-use" extent.
+ *
+ *------------------------------------------------------------------------
+ */
+static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr)
+{
+ Tcl_Size count;
+ ListStore *storePtr;
+ ListSpan *spanPtr;
+
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+ LISTREP_CHECK(repPtr);
+
+ storePtr = repPtr->storePtr;
+ spanPtr = repPtr->spanPtr;
+ if (spanPtr == NULL) {
+ LIST_ASSERT(storePtr->firstUsed == 0); /* Invariant TBD */
+ return;
+ }
+
+ /* Collect garbage at front */
+ count = spanPtr->spanStart - storePtr->firstUsed;
+ LIST_COUNT_ASSERT(count);
+ if (count > 0) {
+ /* T:listrep-1.5.1,6.{1:8} */
+ ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count);
+ storePtr->firstUsed = spanPtr->spanStart;
+ LIST_ASSERT(storePtr->numUsed >= count);
+ storePtr->numUsed -= count;
+ }
+
+ /* Collect garbage at back */
+ count = (storePtr->firstUsed + storePtr->numUsed)
+ - (spanPtr->spanStart + spanPtr->spanLength);
+ LIST_COUNT_ASSERT(count);
+ if (count > 0) {
+ /* T:listrep-6.{1:8} */
+ ObjArrayDecrRefs(
+ storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count);
+ LIST_ASSERT(storePtr->numUsed >= count);
+ storePtr->numUsed -= count;
+ }
+
+ LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed);
+ LISTREP_CHECK(repPtr);
}
/*
@@ -178,20 +1066,23 @@ AttemptNewList(
*
* Tcl_NewListObj --
*
- * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is
- * defined, 'Tcl_DbNewListObj' is called instead.
+ * This function is normally called when not debugging: i.e., when
+ * TCL_MEM_DEBUG is not defined. It creates a new list object from an
+ * (objc,objv) array: that is, each of the objc elements of the array
+ * referenced by objv is inserted as an element into a new Tcl object.
*
- * Value
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewListObj.
*
- * A new list 'Tcl_Obj' to which is appended values from 'objv', or if
- * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no
- * elements. The string representation of the new 'Tcl_Obj' is set to
- * NULL. The refCount of the list is 0.
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The resulting new list object has ref count 0.
*
- * Effect
- *
- * The refCount of each elements in 'objv' is incremented as it is added
- * to the list.
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -201,7 +1092,7 @@ AttemptNewList(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
return Tcl_DbNewListObj(objc, objv, "unknown", 0);
@@ -211,45 +1102,50 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
- Tcl_Obj *listPtr;
+ ListRep listRep;
+ Tcl_Obj *listObj;
- TclNewObj(listPtr);
+ TclNewObj(listObj);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- /*
- * Now create the object.
- */
-
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- return listPtr;
+ return listObj;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
- * Tcl_DbNewListObj --
+ * Tcl_DbNewListObj --
+ *
+ * This function is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
+ * as the Tcl_NewListObj function above except that it calls
+ * Tcl_DbCkalloc directly with the file name and line number from its
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
- * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the
- * file name and line number from its caller. This simplifies debugging
- * since the [memory active] command will report the correct file
- * name and line number when reporting objects that haven't been freed.
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
+ * result of calling Tcl_NewListObj.
*
- * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead.
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The new list object has ref count 0.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -258,95 +1154,189 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size 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
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
- Tcl_Obj *listPtr;
- List *listRepPtr;
+ Tcl_Obj *listObj;
+ ListRep listRep;
- TclDbNewObj(listPtr, file, line);
+ TclDbNewObj(listObj, file, line);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- /*
- * Now create the object.
- */
-
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
-
- return listPtr;
+ return listObj;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size 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
- * function; used for debugging. */
- int line) /* Line number in the source file; used for
- * debugging. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */
/*
+ *------------------------------------------------------------------------
+ *
+ * TclNewListObj2 --
+ *
+ * Create a new Tcl_Obj list comprising of the concatenation of two
+ * Tcl_Obj* arrays.
+ * TODO - currently this function is not used within tclListObj but
+ * need to see if it would be useful in other files that preallocate
+ * lists and then append.
+ *
+ * Results:
+ * Non-NULL pointer to the allocate Tcl_Obj.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclNewListObj2(
+ Tcl_Size objc1, /* Count of objects referenced by objv1. */
+ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
+ Tcl_Size objc2, /* Count of objects referenced by objv2. */
+ Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */
+)
+{
+ Tcl_Obj *listObj;
+ ListStore *storePtr;
+ Tcl_Size objc = objc1 + objc2;
+
+ listObj = Tcl_NewListObj(objc, NULL);
+ if (objc == 0) {
+ return listObj; /* An empty object */
+ }
+ LIST_ASSERT_TYPE(listObj);
+
+ storePtr = ListObjStorePtr(listObj);
+
+ LIST_ASSERT(ListObjSpanPtr(listObj) == NULL);
+ LIST_ASSERT(storePtr->firstUsed == 0);
+ LIST_ASSERT(storePtr->numUsed == 0);
+ LIST_ASSERT(storePtr->numAllocated >= objc);
+
+ if (objc1) {
+ ObjArrayCopy(storePtr->slots, objc1, objv1);
+ }
+ if (objc2) {
+ ObjArrayCopy(&storePtr->slots[objc1], objc2, objv2);
+ }
+ storePtr->numUsed = objc;
+ return listObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclListObjGetRep --
+ *
+ * This function returns a copy of the ListRep stored
+ * as the internal representation of an object. The reference
+ * counts of the (ListStore, ListSpan) contained in the representation
+ * are NOT incremented.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case *listRepP
+ * is set to a copy of the descriptor stored as the internal
+ * representation of the Tcl_Obj containing a list. if listPtr does not
+ * refer to a list object and the object can not be converted to one,
+ * TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object. *repPtr is initialized to the internal rep
+ * if result is TCL_OK, or set to NULL on error.
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclListObjGetRep(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object for which an element array is
+ * to be returned. */
+ ListRep *repPtr) /* Location to store descriptor */
+{
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ int result;
+ result = SetListFromAny(interp, listObj);
+ if (result != TCL_OK) {
+ /* Init to keep gcc happy wrt uninitialized fields at call site */
+ repPtr->storePtr = NULL;
+ repPtr->spanPtr = NULL;
+ return result;
+ }
+ }
+ ListObjGetRep(listObj, repPtr);
+ LISTREP_CHECK(repPtr);
+ return TCL_OK;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_SetListObj --
*
- * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of
- * creating a new one.
+ * Modify an object to be a list containing each of the objc elements of
+ * the object array referenced by objv.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object is made a list object and is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The ref counts of the elements in objv are incremented since the
+ * list now refers to them. The object's old string and internal
+ * representations are freed and its type is set NULL.
*
*----------------------------------------------------------------------
*/
-
void
Tcl_SetListObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
-
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetListObj");
}
/*
- * Free any old string rep and any internal rep for the old type.
- */
-
- TclFreeIntRep(objPtr);
- TclInvalidateStringRep(objPtr);
-
- /*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
- * object an empty string rep and a NULL type.
+ * object an empty string rep and a NULL type. NOTE ListRepInit must
+ * not be called with objc == 0!
*/
if (objc > 0) {
- listRepPtr = NewListInternalRep(objc, objv, 1);
- ListSetInternalRep(objPtr, listRepPtr);
+ ListRep listRep;
+ /* TODO - perhaps ask for extra space? */
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
+ TclFreeInternalRep(objPtr);
+ TclInvalidateStringRep(objPtr);
+ Tcl_InitStringRep(objPtr, NULL, 0);
}
}
@@ -355,20 +1345,18 @@ Tcl_SetListObj(
*
* TclListObjCopy --
*
- * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This
- * provides for the C level a counterpart of the [lrange $list 0 end]
- * command, while using internals details to be as efficient as possible.
+ * Makes a "pure list" copy of a list value. This provides for the C
+ * level a counterpart of the [lrange $list 0 end] command, while using
+ * internals details to be as efficient as possible.
*
- * Value
+ * Results:
+ * Normally returns a pointer to a new Tcl_Obj, that contains the same
+ * list value as *listPtr does. The returned Tcl_Obj has a refCount of
+ * zero. If *listPtr does not hold a list, NULL is returned, and if
+ * interp is non-NULL, an error message is recorded there.
*
- * The address of the new 'Tcl_Obj' which shares its internal
- * representation with 'listPtr', and whose refCount is 0. If 'listPtr'
- * is not actually a list, the value is NULL, and an error message is left
- * in 'interp' if it is not NULL.
- *
- * Effect
- *
- * 'listPtr' is converted to a list if it isn't one already.
+ * Side effects:
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -376,84 +1364,317 @@ Tcl_SetListObj(
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr) /* List object for which an element array is
+ Tcl_Obj *listObj) /* List object for which an element array is
* to be returned. */
{
- Tcl_Obj *copyPtr;
+ Tcl_Obj *copyObj;
- if (listPtr->typePtr != &tclListType) {
- if (SetListFromAny(interp, listPtr) != TCL_OK) {
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ return TclArithSeriesObjCopy(interp, listObj);
+ }
+ if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
}
}
- TclNewObj(copyPtr);
- TclInvalidateStringRep(copyPtr);
- DupListInternalRep(listPtr, copyPtr);
- return copyPtr;
+ TclNewObj(copyObj);
+ TclInvalidateStringRep(copyObj);
+ DupListInternalRep(listObj, copyObj);
+ return copyObj;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepRange --
+ *
+ * Initializes a ListRep as a range within the passed ListRep.
+ * The range limits are clamped to the list boundaries.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The ListStore and ListSpan referenced by in the returned ListRep
+ * may or may not be the same as those passed in. For example, the
+ * ListStore may differ because the range is small enough that a new
+ * ListStore is more memory-optimal. The ListSpan may differ because
+ * it is NULL or shared. Regardless, reference counts on the returned
+ * values are not incremented. Generally, ListObjReplaceRepAndInvalidate
+ * may be used to store the new ListRep back into an object or a
+ * ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors.
+ * Any other use should be carefully reconsidered.
+ * TODO WARNING:- this is an awkward interface and easy for caller
+ * to get wrong. Mostly due to refcount combinations. Perhaps passing
+ * in the source listObj instead of source listRep might simplify.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRepRange(
+ ListRep *srcRepPtr, /* Contains source of the range */
+ Tcl_Size rangeStart, /* Index of first element to include */
+ Tcl_Size rangeEnd, /* Index of last element to include */
+ int preserveSrcRep, /* If true, srcRepPtr contents must not be
+ modified (generally because a shared Tcl_Obj
+ references it) */
+ ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
+{
+ Tcl_Obj **srcElems;
+ Tcl_Size numSrcElems = ListRepLength(srcRepPtr);
+ Tcl_Size rangeLen;
+ Tcl_Size numAfterRangeEnd;
+
+ LISTREP_CHECK(srcRepPtr);
+
+ /* Take the opportunity to garbage collect */
+ /* TODO - we probably do not need the preserveSrcRep here unlike later */
+ if (!preserveSrcRep) {
+ /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
+ ListRepFreeUnreferenced(srcRepPtr);
+ } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
+
+ if (rangeStart < 0) {
+ rangeStart = 0;
+ }
+ if (rangeEnd >= numSrcElems) {
+ rangeEnd = numSrcElems - 1;
+ }
+ if (rangeStart > rangeEnd) {
+ /* Empty list of capacity 1. */
+ ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
+ return;
+ }
+
+ rangeLen = rangeEnd - rangeStart + 1;
+
+ /*
+ * We can create a range one of four ways:
+ * (0) Range encapsulates entire list
+ * (1) Special case: deleting in-place from end of an unshared object
+ * (2) Use a ListSpan referencing the current ListStore
+ * (3) Creating a new ListStore
+ * (4) Removing all elements outside the range in the current ListStore
+ * Option (4) may only be done if caller has not disallowed it AND
+ * the ListStore is not shared.
+ *
+ * The choice depends on heuristics related to speed and memory.
+ * TODO - heuristics below need to be measured and tuned.
+ *
+ * Note: Even if nothing below cause any changes, we still want the
+ * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
+ * be returned as is even if the range encompasses the whole list.
+ */
+ if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
+ /* Option 0 - entire list. This may be used to canonicalize */
+ /* T:listrep-1.10.1,2.8.1 */
+ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
+ } else if (rangeStart == 0 && (!preserveSrcRep)
+ && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
+ /* Option 1 - Special case unshared, exclude end elements, no span */
+ LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
+ numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
+ /* Assert: Because numSrcElems > rangeEnd earlier */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ if (numAfterRangeEnd != 0) {
+ /* T:listrep-1.{8,9} */
+ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ }
+ /* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
+ srcRepPtr->storePtr->numUsed = rangeLen;
+ srcRepPtr->storePtr->flags = 0;
+ rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
+ rangeRepPtr->spanPtr = NULL;
+ } else if (ListSpanMerited(rangeLen,
+ srcRepPtr->storePtr->numUsed,
+ srcRepPtr->storePtr->numAllocated)) {
+ /* Option 2 - because span would be most efficient */
+ Tcl_Size spanStart = ListRepStart(srcRepPtr) + rangeStart;
+ if (!preserveSrcRep && srcRepPtr->spanPtr
+ && srcRepPtr->spanPtr->refCount <= 1) {
+ /* If span is not shared reuse it */
+ /* T:listrep-2.7.3,3.{16,18} */
+ srcRepPtr->spanPtr->spanStart = spanStart;
+ srcRepPtr->spanPtr->spanLength = rangeLen;
+ *rangeRepPtr = *srcRepPtr;
+ } else {
+ /* Span not present or is shared. */
+ /* T:listrep-1.5,2.{5,7},4.{7,8} */
+ rangeRepPtr->storePtr = srcRepPtr->storePtr;
+ rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen);
+ }
+ /*
+ * We have potentially created a new internal representation that
+ * references the same storage as srcRep but not yet incremented its
+ * reference count. So do NOT call freezombies if preserveSrcRep
+ * is mandated.
+ */
+ if (!preserveSrcRep) {
+ /* T:listrep-1.{5.1,5.2,5.4},2.{5,7},3.{16,18},4.{7,8} */
+ ListRepFreeUnreferenced(rangeRepPtr);
+ }
+ } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
+ /* Option 3 - span or modification in place not allowed/desired */
+ /* T:listrep-2.{4,6} */
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
+ /* TODO - allocate extra space? */
+ ListRepInit(rangeLen,
+ &srcElems[rangeStart],
+ LISTREP_PANIC_ON_FAIL,
+ rangeRepPtr);
+ } else {
+ /*
+ * Option 4 - modify in place. Note that because of the invariant
+ * that spanless list stores must start at 0, we have to move
+ * everything to the front.
+ * TODO - perhaps if a span already exists, no need to move to front?
+ * or maybe no need to move all the way to the front?
+ * TODO - if range is small relative to allocation, allocate new?
+ */
+
+ /* Asserts follow from call to ListRepFreeUnreferenced earlier */
+ LIST_ASSERT(!preserveSrcRep);
+ LIST_ASSERT(!ListRepIsShared(srcRepPtr));
+ LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
+
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
+
+ /* Free leading elements outside range */
+ if (rangeStart != 0) {
+ /* T:listrep-1.4,3.15 */
+ ObjArrayDecrRefs(srcElems, 0, rangeStart);
+ }
+ /* Ditto for trailing */
+ numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
+ /* Assert: Because numSrcElems > rangeEnd earlier */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ if (numAfterRangeEnd != 0) {
+ /* T:listrep-3.17 */
+ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ }
+ memmove(&srcRepPtr->storePtr->slots[0],
+ &srcRepPtr->storePtr
+ ->slots[srcRepPtr->storePtr->firstUsed + rangeStart],
+ rangeLen * sizeof(Tcl_Obj *));
+ srcRepPtr->storePtr->firstUsed = 0;
+ srcRepPtr->storePtr->numUsed = rangeLen;
+ srcRepPtr->storePtr->flags = 0;
+ if (srcRepPtr->spanPtr) {
+ /* In case the source has a span, update it for consistency */
+ /* T:listrep-3.{15,17} */
+ srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed;
+ srcRepPtr->spanPtr->spanLength = srcRepPtr->storePtr->numUsed;
+ }
+ rangeRepPtr->storePtr = srcRepPtr->storePtr;
+ rangeRepPtr->spanPtr = NULL;
+ }
+
+ /* TODO - call freezombies here if !preserveSrcRep? */
+
+ /* Note ref counts intentionally not incremented */
+ LISTREP_CHECK(rangeRepPtr);
+ return;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjGetElements --
+ * TclListObjRange --
*
- * Retreive the elements in a list 'Tcl_Obj'.
+ * Makes a slice of a list value.
+ * *listObj must be known to be a valid list.
*
- * Value
+ * Results:
+ * Returns a pointer to the sliced list.
+ * This may be a new object or the same object if not shared.
+ * Returns NULL if passed listObj was not a list and could not be
+ * converted to one.
*
- * TCL_OK
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object.
*
- * A count of list elements is stored, 'objcPtr', And a pointer to the
- * array of elements in the list is stored in 'objvPtr'.
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclListObjRange(
+ Tcl_Obj *listObj, /* List object to take a range from. */
+ Tcl_Size rangeStart, /* Index of first element to include. */
+ Tcl_Size rangeEnd) /* Index of last element to include. */
+{
+ ListRep listRep;
+ ListRep resultRep;
+
+ int isShared;
+ if (TclListObjGetRep(NULL, listObj, &listRep) != TCL_OK)
+ return NULL;
+
+ isShared = Tcl_IsShared(listObj);
+
+ ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
+
+ if (isShared) {
+ /* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
+ TclNewObj(listObj);
+ } /* T:listrep-1.{4.3,5.1,5.2} */
+ ListObjReplaceRepAndInvalidate(listObj, &resultRep);
+ return listObj;
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * The elements accessible via 'objvPtr' should be treated as readonly
- * and the refCount for each object is _not_ incremented; the caller
- * must do that if it holds on to a reference. Furthermore, the
- * pointer and length returned by this function may change as soon as
- * any function is called on the list object. Be careful about
- * retaining the pointer in a local data structure.
+ * Tcl_ListObjGetElements --
*
- * TCL_ERROR
+ * This function returns an (objc,objv) array of the elements in a list
+ * object.
*
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * Results:
+ * The return value is normally TCL_OK; in this case *objcPtr is set to
+ * the count of list elements and *objvPtr is set to a pointer to an
+ * array of (*objcPtr) pointers to each list element. If listPtr does not
+ * refer to a list object and the object can not be converted to one,
+ * TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
*
- * Effect
+ * The objects referenced by the returned array should be treated as
+ * readonly and their ref counts are _not_ incremented; the caller must
+ * do that if it holds on to a reference. Furthermore, the pointer and
+ * length returned by this function may change as soon as any function is
+ * called on the list object; be careful about retaining the pointer in a
+ * local data structure.
*
- * 'listPtr' is converted to a list object if it isn't one already.
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object.
*
*----------------------------------------------------------------------
*/
+#undef Tcl_ListObjGetElements
int
Tcl_ListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object for which an element array is
+ Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
- int *objcPtr, /* Where to store the count of objects
+ Tcl_Size *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
- List *listRepPtr;
+ ListRep listRep;
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- if (listPtr->bytes == tclEmptyStringRep) {
- *objcPtr = 0;
- *objvPtr = NULL;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr);
}
- listRepPtr = ListRepPtr(listPtr);
- *objcPtr = listRepPtr->elemCount;
- *objvPtr = &listRepPtr->elements;
+
+ if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
+ return TCL_ERROR;
+ ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
@@ -462,49 +1683,37 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * Appends the elements of elemListPtr to those of listPtr.
+ * This function appends the elements in the list fromObj
+ * to toObj. toObj must not be shared else the function will panic.
*
- * Value
+ * Results:
+ * The return value is normally TCL_OK. If fromObj or toObj do not
+ * refer to list values, TCL_ERROR is returned and an error message is
+ * left in the interpreter's result if interp is not NULL.
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' or 'elemListPtr' are not valid lists. An error
- * message is left in the interpreter's result if 'interp' is not NULL.
- *
- * Effect
- *
- * The reference count of each element of 'elemListPtr' as it is added to
- * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType'
- * if they are not already. Appending the new elements may cause the
- * array of element pointers in 'listObj' to grow. If any objects are
- * appended to 'listPtr'. Any preexisting string representation of
- * 'listPtr' is invalidated.
+ * Side effects:
+ * The reference counts of the elements in fromObj are incremented
+ * since the list now refers to them. toObj and fromObj are
+ * converted, if necessary, to list objects. Also, appending the new
+ * elements may cause toObj's array of element pointers to grow.
+ * toObj's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to append elements to. */
- Tcl_Obj *elemListPtr) /* List obj with elements to append. */
+ Tcl_Obj *toObj, /* List object to append elements to. */
+ Tcl_Obj *fromObj) /* List obj with elements to append. */
{
- int objc;
+ Tcl_Size objc;
Tcl_Obj **objv;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- /*
- * Pull the elements to append from elemListPtr.
- */
-
- if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
+ if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -513,237 +1722,246 @@ Tcl_ListObjAppendList(
* Delete zero existing elements.
*/
- return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
+ return TclListObjAppendElements(interp, toObj, objc, objv);
}
/*
- *----------------------------------------------------------------------
- *
- * Tcl_ListObjAppendElement --
- *
- * Like 'Tcl_ListObjAppendList', but Appends a single value to a list.
+ *------------------------------------------------------------------------
*
- * Value
+ * TclListObjAppendElements --
*
- * TCL_OK
+ * Appends multiple elements to a Tcl_Obj list object. If
+ * the passed Tcl_Obj is not a list object, it will be converted to one
+ * and an error raised if the conversion fails.
*
- * 'objPtr' is appended to the elements of 'listPtr'.
+ * The Tcl_Obj must not be shared though the internal representation
+ * may be.
*
- * TCL_ERROR
+ * Results:
+ * On success, TCL_OK is returned with the specified elements appended.
+ * On failure, TCL_ERROR is returned with an error message in the
+ * interpreter if not NULL.
*
- * listPtr does not refer to a list object and the object can not be
- * converted to one. An error message will be left in the
- * interpreter's result if interp is not NULL.
+ * Side effects:
+ * None.
*
- * Effect
- *
- * If 'listPtr' is not already of type 'tclListType', it is converted.
- * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
- * Appending the new element may cause the the array of element pointers
- * in 'listObj' to grow. Any preexisting string representation of
- * 'listPtr' is invalidated.
- *
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*/
-
-int
-Tcl_ListObjAppendElement(
+ int TclListObjAppendElements (
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to append objPtr to. */
- Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
+ Tcl_Obj *toObj, /* List object to append */
+ Tcl_Size elemCount, /* Number of elements in elemObjs[] */
+ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */
{
- List *listRepPtr, *newPtr = NULL;
- int numElems, numRequired, needGrow, isShared, attempt;
+ ListRep listRep;
+ Tcl_Obj **toObjv;
+ Tcl_Size toLen;
+ Tcl_Size finalLen;
- if (Tcl_IsShared(listPtr)) {
- Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
- }
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- if (listPtr->bytes == tclEmptyStringRep) {
- Tcl_SetListObj(listPtr, 1, &objPtr);
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (Tcl_IsShared(toObj)) {
+ Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
}
- listRepPtr = ListRepPtr(listPtr);
- numElems = listRepPtr->elemCount;
- numRequired = numElems + 1 ;
- needGrow = (numRequired > listRepPtr->maxElemCount);
- isShared = (listRepPtr->refCount > 1);
+ if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
- if (numRequired > LIST_MAX) {
- if (interp != NULL) {
- 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;
- }
+ if (elemCount == 0)
+ return TCL_OK; /* Nothing to do. Note AFTER check for list above */
- if (needGrow && !isShared) {
- /*
- * Need to grow + unshared internalrep => try to realloc
- */
-
- attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr) {
- listRepPtr = newPtr;
- listRepPtr->maxElemCount = attempt;
- needGrow = 0;
- }
+ ListRepElements(&listRep, toLen, toObjv);
+ if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
+ return ListLimitExceededError(interp);
}
- if (isShared || needGrow) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
+ finalLen = toLen + elemCount;
+ if (!ListRepIsShared(&listRep)) {
/*
- * Either we have a shared internalrep and we must copy to write, or we
- * need to grow and realloc attempts failed. Attempt internalrep copy.
+ * Reuse storage if possible. Even if too small, realloc-ing instead
+ * of creating a new ListStore will save us on manipulating Tcl_Obj
+ * reference counts on the elements which is a substantial cost
+ * if the list is not small.
*/
+ Tcl_Size numTailFree;
- attempt = 2 * numRequired;
- newPtr = AttemptNewList(NULL, attempt, NULL);
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = AttemptNewList(NULL, attempt, NULL);
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = AttemptNewList(interp, attempt, NULL);
- }
- if (newPtr == NULL) {
- /*
- * All growth attempts failed; throw the error.
- */
+ ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */
- return TCL_ERROR;
- }
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed);
+ LIST_ASSERT(toLen == listRep.storePtr->numUsed);
- dst = &newPtr->elements;
- newPtr->refCount++;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
- newPtr->elemCount = listRepPtr->elemCount;
-
- if (isShared) {
- /*
- * The original internalrep must remain undisturbed. Copy into the new
- * one and bump refcounts
- */
- while (numElems--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
+ if (finalLen > listRep.storePtr->numAllocated) {
+ /* T:listrep-1.{2,11},3.6 */
+ ListStore *newStorePtr;
+ newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen);
+ if (newStorePtr == NULL) {
+ return MemoryAllocationError(interp, LIST_SIZE(finalLen));
}
- listRepPtr->refCount--;
- } else {
+ LIST_ASSERT(newStorePtr->numAllocated >= finalLen);
+ listRep.storePtr = newStorePtr;
/*
- * Old internalrep to be freed, re-use refCounts.
+ * WARNING: at this point the Tcl_Obj internal rep potentially
+ * points to freed storage if the reallocation returned a
+ * different location. Overwrite it to bring it back in sync.
*/
-
- memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
- ckfree(listRepPtr);
- }
- listRepPtr = newPtr;
+ ListObjStompRep(toObj, &listRep);
+ } /* else T:listrep-3.{4,5} */
+ LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
+ /* Current store big enough */
+ numTailFree = ListRepNumFreeTail(&listRep);
+ LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed)
+ >= elemCount); /* Total free */
+ if (numTailFree < elemCount) {
+ /* Not enough room at back. Move some to front */
+ /* T:listrep-3.5 */
+ Tcl_Size shiftCount = elemCount - numTailFree;
+ /* Divide remaining space between front and back */
+ shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
+ LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
+ if (shiftCount) {
+ /* T:listrep-3.5 */
+ ListRepUnsharedShiftDown(&listRep, shiftCount);
+ }
+ } /* else T:listrep-3.{4,6} */
+ ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep)
+ + ListRepLength(&listRep)],
+ elemCount,
+ elemObjv);
+ listRep.storePtr->numUsed = finalLen;
+ if (listRep.spanPtr) {
+ /* T:listrep-3.{4,5,6} */
+ LIST_ASSERT(listRep.spanPtr->spanStart
+ == listRep.storePtr->firstUsed);
+ listRep.spanPtr->spanLength = finalLen;
+ } /* else T:listrep-3.6.3 */
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(&listRep) == finalLen);
+ LISTREP_CHECK(&listRep);
+
+ ListObjReplaceRepAndInvalidate(toObj, &listRep);
+ return TCL_OK;
}
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
/*
- * Add objPtr to the end of listPtr's array of element pointers. Increment
- * the ref count for the (now shared) objPtr.
- */
-
- *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
- Tcl_IncrRefCount(objPtr);
- listRepPtr->elemCount++;
-
- /*
- * Invalidate any old string representation since the list's internal
- * representation has changed.
+ * Have to make a new list rep, either shared or no room in old one.
+ * If the old list did not have a span (all elements at front), do
+ * not leave space in the front either, assuming all appends and no
+ * prepends.
*/
+ if (ListRepInit(finalLen,
+ NULL,
+ listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK
+ : LISTREP_SPACE_ONLY_BACK,
+ &listRep)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
- TclInvalidateStringRep(listPtr);
+ if (toLen) {
+ /* T:listrep-2.{2,9},4.5 */
+ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv);
+ }
+ ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv);
+ listRep.storePtr->numUsed = finalLen;
+ if (listRep.spanPtr) {
+ /* T:listrep-4.5 */
+ LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed);
+ listRep.spanPtr->spanLength = finalLen;
+ }
+ LISTREP_CHECK(&listRep);
+ ListObjReplaceRepAndInvalidate(toObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjIndex --
- *
- * Retrieve a pointer to the element of 'listPtr' at 'index'. The index
- * of the first element is 0.
- *
- * Value
+ * Tcl_ListObjAppendElement --
*
- * TCL_OK
+ * This function is a special purpose version of Tcl_ListObjAppendList:
+ * it appends a single object referenced by elemObj to the list object
+ * referenced by toObj. If toObj is not already a list object, an
+ * attempt will be made to convert it to one.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case elemObj is added to
+ * the end of toObj's list. If toObj does not refer to a list object
+ * and the object can not be converted to one, TCL_ERROR is returned and
+ * an error message will be left in the interpreter's result if interp is
+ * not NULL.
+ *
+ * Side effects:
+ * The ref count of elemObj is incremented since the list now refers to
+ * it. toObj will be converted, if necessary, to a list object. Also,
+ * appending the new element may cause listObj's array of element
+ * pointers to grow. toObj's old string representation, if any, is
+ * invalidated.
*
- * A pointer to the element at 'index' is stored in 'objPtrPtr'. If
- * 'index' is out of range, NULL is stored in 'objPtrPtr'. This
- * object should be treated as readonly and its 'refCount' is _not_
- * incremented. The caller must do that if it holds on to the
- * reference.
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_ListObjAppendElement(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *toObj, /* List object to append elemObj to. */
+ Tcl_Obj *elemObj) /* Object to append to toObj's list. */
+{
+ /*
+ * TODO - compare perf with 8.6 to see if worth optimizing single
+ * element case
+ */
+ return TclListObjAppendElements(interp, toObj, 1, &elemObj);
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * TCL_ERROR
+ * Tcl_ListObjIndex --
*
- * 'listPtr' is not a valid list. An an error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * This function returns a pointer to the index'th object from the list
+ * referenced by listPtr. The first element has index 0. If index is
+ * negative or greater than or equal to the number of elements in the
+ * list, a NULL is returned. If listPtr is not a list object, an attempt
+ * will be made to convert it to a list.
*
- * Effect
+ * Results:
+ * The return value is normally TCL_OK; in this case objPtrPtr is set to
+ * the Tcl_Obj pointer for the index'th list element or NULL if index is
+ * out of range. This object should be treated as readonly and its ref
+ * count is _not_ incremented; the caller must do that if it holds on to
+ * the reference. If listPtr does not refer to a list and can't be
+ * converted to one, TCL_ERROR is returned and an error message is left
+ * in the interpreter's result if interp is not NULL.
*
- * If 'listPtr' is not already of type 'tclListType', it is converted.
+ * Side effects:
+ * listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjIndex(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to index into. */
- int index, /* Index of element to return. */
- Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object to index into. */
+ Tcl_Size index, /* Index of element to return. */
+ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
- List *listRepPtr;
-
- if (listPtr->typePtr != &tclListType) {
- int result;
+ Tcl_Obj **elemObjs;
+ Tcl_Size numElems;
- if (listPtr->bytes == tclEmptyStringRep) {
- *objPtrPtr = NULL;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
+ != TCL_OK) {
+ return TCL_ERROR;
}
-
- listRepPtr = ListRepPtr(listPtr);
- if ((index < 0) || (index >= listRepPtr->elemCount)) {
+ if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = (&listRepPtr->elements)[index];
+ *objPtrPtr = elemObjs[index];
}
return TCL_OK;
@@ -754,47 +1972,48 @@ Tcl_ListObjIndex(
*
* Tcl_ListObjLength --
*
- * Retrieve the number of elements in a list.
+ * This function returns the number of elements in a list object. If the
+ * object is not already a list object, an attempt will be made to
+ * convert it to one.
*
- * Value
+ * Results:
+ * The return value is normally TCL_OK; in this case *lenPtr will be set
+ * to the integer count of list elements. If listPtr does not refer to a
+ * list object and the object can not be converted to one, TCL_ERROR is
+ * returned and an error message will be left in the interpreter's result
+ * if interp is not NULL.
*
- * TCL_OK
- *
- * A count of list elements is stored at the address provided by
- * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is
- * converted.
- *
- * TCL_ERROR
- *
- * 'listPtr' is not a valid list. An error message will be left in
- * the interpreter's result if 'interp' is not NULL.
+ * Side effects:
+ * The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
+#undef Tcl_ListObjLength
int
Tcl_ListObjLength(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object whose #elements to return. */
- int *intPtr) /* The resulting int is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object whose #elements to return. */
+ Tcl_Size *lenPtr) /* The resulting length is stored here. */
{
- List *listRepPtr;
+ ListRep listRep;
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- if (listPtr->bytes == tclEmptyStringRep) {
- *intPtr = 0;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ *lenPtr = TclArithSeriesObjLength(listObj);
+ return TCL_OK;
}
- listRepPtr = ListRepPtr(listPtr);
- *intPtr = listRepPtr->elemCount;
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
@@ -803,285 +2022,498 @@ Tcl_ListObjLength(
*
* Tcl_ListObjReplace --
*
- * Replace values in a list.
- *
- * If 'first' is zero or negative, it refers to the first element. If
- * 'first' outside the range of elements in the list, no elements are
- * deleted.
- *
- * If 'count' is zero or negative no elements are deleted, and any new
- * elements are inserted at the beginning of the list.
- *
- * Value
- *
- * TCL_OK
- *
- * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr'
- * starting at 'first'. If 'objc' 0, no new elements are added.
- *
- * TCL_ERROR
- *
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
- *
- * Effect
- *
- * If 'listPtr' is not of type 'tclListType', it is converted if possible.
- *
- * The 'refCount' of each element appended to the list is incremented.
- * Similarly, the 'refCount' for each replaced element is decremented.
- *
- * If 'listPtr' is modified, any previous string representation is
- * invalidated.
+ * This function replaces zero or more elements of the list referenced by
+ * listObj with the objects from an (objc,objv) array. The objc elements
+ * of the array referenced by objv replace the count elements in listPtr
+ * starting at first.
+ *
+ * If the argument first is zero or negative, it refers to the first
+ * element. If first is greater than or equal to the number of elements
+ * in the list, then no elements are deleted; the new elements are
+ * appended to the list. Count gives the number of elements to replace.
+ * If count is zero or negative then no elements are deleted; the new
+ * elements are simply inserted before first.
+ *
+ * The argument objv refers to an array of objc pointers to the new
+ * elements to be added to listPtr in place of those that were deleted.
+ * If objv is NULL, no new elements are added. If listPtr is not a list
+ * object, an attempt will be made to convert it to one.
+ *
+ * Results:
+ * The return value is normally TCL_OK. If listPtr does not refer to a
+ * list object and can not be converted to one, TCL_ERROR is returned and
+ * an error message will be left in the interpreter's result if interp is
+ * not NULL.
+ *
+ * Side effects:
+ * The ref counts of the objc elements in objv are incremented since the
+ * resulting list now refers to them. Similarly, the ref counts for
+ * replaced objects are decremented. listObj is converted, if necessary,
+ * to a list object. listObj's old string representation, if any, is
+ * freed.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjReplace(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- Tcl_Obj *listPtr, /* List object whose elements to replace. */
- 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
- * insert. */
+ Tcl_Obj *listObj, /* List object whose elements to replace. */
+ Tcl_Size first, /* Index of first element to replace. */
+ Tcl_Size numToDelete, /* Number of elements to replace. */
+ Tcl_Size numToInsert, /* Number of objects to insert. */
+ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */
{
- List *listRepPtr;
- Tcl_Obj **elemPtrs;
- int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
-
- if (Tcl_IsShared(listPtr)) {
+ ListRep listRep;
+ Tcl_Size origListLen;
+ int lenChange;
+ int leadSegmentLen;
+ int tailSegmentLen;
+ Tcl_Size numFreeSlots;
+ int leadShift;
+ int tailShift;
+ Tcl_Obj **listObjs;
+ int favor;
+
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == tclEmptyStringRep) {
- if (!objc) {
- return TCL_OK;
- }
- Tcl_SetListObj(listPtr, objc, NULL);
- } else {
- int result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- }
- }
-
- /*
- * Note that when count == 0 and objc == 0, this routine is logically a
- * no-op, removing and adding no elements to the list. However, by flowing
- * through this routine anyway, we get the important side effect that the
- * resulting listPtr is a list in canoncial form. This is important.
- * Resist any temptation to optimize this case.
- */
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
- listRepPtr = ListRepPtr(listPtr);
- elemPtrs = &listRepPtr->elements;
- numElems = listRepPtr->elemCount;
+ /* TODO - will need modification if Tcl9 sticks to unsigned indices */
+ /* Make limits sane */
+ origListLen = ListRepLength(&listRep);
if (first < 0) {
first = 0;
}
- if (first >= numElems) {
- first = numElems; /* So we'll insert after last element. */
+ if (first > origListLen) {
+ first = origListLen; /* So we'll insert after last element. */
}
- if (count < 0) {
- count = 0;
- } else if (count > LIST_MAX /* Handle integer overflow */
- || numElems < first+count) {
-
- count = numElems - first;
+ if (numToDelete < 0) {
+ numToDelete = 0;
+ } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */
+ || origListLen < first + numToDelete) {
+ numToDelete = origListLen - first;
}
- if (objc > LIST_MAX - (numElems - count)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
- }
- return TCL_ERROR;
+ if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) {
+ return ListLimitExceededError(interp);
}
- isShared = (listRepPtr->refCount > 1);
- numRequired = numElems - count + objc; /* Known <= LIST_MAX */
- needGrow = numRequired > listRepPtr->maxElemCount;
- for (i = 0; i < objc; i++) {
- Tcl_IncrRefCount(objv[i]);
+ if ((first+numToDelete) >= origListLen) {
+ /* Operating at back of list. Favor leaving space at back */
+ favor = LISTREP_SPACE_FAVOR_BACK;
+ } else if (first == 0) {
+ /* Operating on front of list. Favor leaving space in front */
+ favor = LISTREP_SPACE_FAVOR_FRONT;
+ } else {
+ /* Operating on middle of list. */
+ favor = LISTREP_SPACE_FAVOR_NONE;
}
- if (needGrow && !isShared) {
- /* Try to use realloc */
- List *newPtr = NULL;
- int attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ /*
+ * There are a number of special cases to consider from an optimization
+ * point of view.
+ * (1) Pure deletes (numToInsert==0) from the front or back can be treated
+ * as a range op irrespective of whether the ListStore is shared or not
+ * (2) Pure inserts (numToDelete == 0)
+ * (2a) Pure inserts at the back can be treated as appends
+ * (2b) Pure inserts from the *front* can be optimized under certain
+ * conditions by inserting before first ListStore slot in use if there
+ * is room, again irrespective of sharing
+ * (3) If the ListStore is shared OR there is insufficient free space
+ * OR existing allocation is too large compared to new size, create
+ * a new ListStore
+ * (4) Unshared ListStore with sufficient free space. Delete, shift and
+ * insert within the ListStore.
+ */
+
+ /* Note: do not do TclInvalidateStringRep as yet in case there are errors */
+
+ /* Check Case (1) - Treat pure deletes from front or back as range ops */
+ if (numToInsert == 0) {
+ if (numToDelete == 0) {
+ /*
+ * Should force canonical even for no-op. Remember Tcl_Obj unshared
+ * so OK to invalidate string rep
+ */
+ /* T:listrep-1.10,2.8 */
+ TclInvalidateStringRep(listObj);
+ return TCL_OK;
}
- if (newPtr) {
- listRepPtr = newPtr;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- elemPtrs = &listRepPtr->elements;
- listRepPtr->maxElemCount = attempt;
- needGrow = numRequired > listRepPtr->maxElemCount;
+ if (first == 0) {
+ /* Delete from front, so return tail. */
+ /* T:listrep-1.{4,5},2.{4,5},3.{15,16},4.7 */
+ ListRep tailRep;
+ ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep);
+ ListObjReplaceRepAndInvalidate(listObj, &tailRep);
+ return TCL_OK;
+ } else if ((first+numToDelete) >= origListLen) {
+ /* Delete from tail, so return head */
+ /* T:listrep-1.{8,9},2.{6,7},3.{17,18},4.8 */
+ ListRep headRep;
+ ListRepRange(&listRep, 0, first-1, 0, &headRep);
+ ListObjReplaceRepAndInvalidate(listObj, &headRep);
+ return TCL_OK;
}
+ /* Deletion from middle. Fall through to general case */
}
- if (!needGrow && !isShared) {
- int shift;
- /*
- * Can use the current List struct. First "delete" count elements
- * starting at first.
- */
+ /* Garbage collect before checking the pure insert optimization */
+ ListRepFreeUnreferenced(&listRep);
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = elemPtrs[j];
-
- TclDecrRefCount(victimPtr);
+ /*
+ * Check Case (2) - pure inserts under certain conditions:
+ */
+ if (numToDelete == 0) {
+ /* Case (2a) - Append to list. */
+ if (first == origListLen) {
+ /* T:listrep-1.11,2.9,3.{5,6},2.2.1 */
+ return TclListObjAppendElements(
+ interp, listObj, numToInsert, insertObjs);
}
/*
- * Shift the elements after the last one removed to their new
- * locations.
+ * Case (2b) - pure inserts at front under some circumstances
+ * (i) Insertion must be at head of list
+ * (ii) The list's span must be at head of the in-use slots in the store
+ * (iii) There must be unused room at front of the store
+ * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not
+ * affect the other Tcl_Obj's referencing this ListStore.
*/
+ if (first == 0 && /* (i) */
+ ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */
+ numToInsert <= listRep.storePtr->firstUsed /* (iii) */
+ ) {
+ Tcl_Size newLen;
+ LIST_ASSERT(numToInsert); /* Else would have returned above */
+ listRep.storePtr->firstUsed -= numToInsert;
+ ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
+ numToInsert,
+ insertObjs);
+ listRep.storePtr->numUsed += numToInsert;
+ newLen = listRep.spanPtr->spanLength + numToInsert;
+ if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
+ /* An unshared span record, re-use it */
+ /* T:listrep-3.1 */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = newLen;
+ } else {
+ /* Need a new span record */
+ if (listRep.storePtr->firstUsed == 0) {
+ listRep.spanPtr = NULL;
+ } else {
+ /* T:listrep-4.3 */
+ listRep.spanPtr =
+ ListSpanNew(listRep.storePtr->firstUsed, newLen);
+ }
+ }
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
+ return TCL_OK;
+ }
+ }
- start = first + count;
- numAfterLast = numElems - start;
- shift = objc - count; /* numNewElems - numDeleted */
- if ((numAfterLast > 0) && (shift != 0)) {
- Tcl_Obj **src = elemPtrs + start;
+ /* Just for readability of the code */
+ lenChange = numToInsert - numToDelete;
+ leadSegmentLen = first;
+ tailSegmentLen = origListLen - (first + numToDelete);
+ numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
- memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*));
+ /*
+ * Before further processing, if unshared, try and reallocate to avoid
+ * new allocation below. This avoids expensive ref count manipulation
+ * later by not having to go through the ListRepInit and
+ * ListObjReplaceAndInvalidate below.
+ * TODO - we could be smarter about the reallocate. Use of realloc
+ * means all new free space is at the back. Instead, the realloc could
+ * be an explicit alloc and memmove which would let us redistribute
+ * free space.
+ */
+ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) {
+ /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */
+ ListStore *newStorePtr =
+ ListStoreReallocate(listRep.storePtr, origListLen + lenChange);
+ if (newStorePtr == NULL) {
+ return MemoryAllocationError(interp,
+ LIST_SIZE(origListLen + lenChange));
}
- } else {
+ listRep.storePtr = newStorePtr;
+ numFreeSlots =
+ listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
/*
- * Cannot use the current List struct; it is shared, too small, or
- * both. Allocate a new struct and insert elements into it.
+ * WARNING: at this point the Tcl_Obj internal rep potentially
+ * points to freed storage if the reallocation returned a
+ * different location. Overwrite it to bring it back in sync.
*/
+ ListObjStompRep(listObj, &listRep);
+ }
- List *oldListRepPtr = listRepPtr;
- Tcl_Obj **oldPtrs = elemPtrs;
- int newMax;
-
- if (needGrow){
- newMax = 2 * numRequired;
- } else {
- newMax = listRepPtr->maxElemCount;
+ /*
+ * Case (3) a new ListStore is required
+ * (a) The passed-in ListStore is shared
+ * (b) There is not enough free space in the unshared passed-in ListStore
+ * (c) The new unshared size is much "smaller" (TODO) than the allocated space
+ * TODO - for unshared case ONLY, consider a "move" based implementation
+ */
+ if (ListRepIsShared(&listRep) || /* 3a */
+ numFreeSlots < lenChange || /* 3b */
+ (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */
+ ) {
+ ListRep newRep;
+ Tcl_Obj **toObjs;
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
+ ListRepInit(origListLen + lenChange,
+ NULL,
+ LISTREP_PANIC_ON_FAIL | favor,
+ &newRep);
+ toObjs = ListRepSlotPtr(&newRep, 0);
+ if (leadSegmentLen > 0) {
+ /* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */
+ ObjArrayCopy(toObjs, leadSegmentLen, listObjs);
}
-
- listRepPtr = AttemptNewList(NULL, newMax, NULL);
- if (listRepPtr == NULL) {
- unsigned int limit = LIST_MAX - numRequired;
- unsigned int extra = numRequired - numElems
- + TCL_MIN_ELEMENT_GROWTH;
- int growth = (int) ((extra > limit) ? limit : extra);
-
- listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
- if (listRepPtr == NULL) {
- listRepPtr = AttemptNewList(interp, numRequired, NULL);
- if (listRepPtr == NULL) {
- for (i = 0; i < objc; i++) {
- /* See bug 3598580 */
-#if TCL_MAJOR_VERSION > 8
- Tcl_DecrRefCount(objv[i]);
-#else
- objv[i]->refCount--;
-#endif
- }
- return TCL_ERROR;
- }
- }
+ if (numToInsert > 0) {
+ /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */
+ ObjArrayCopy(&toObjs[leadSegmentLen],
+ numToInsert,
+ insertObjs);
+ }
+ if (tailSegmentLen > 0) {
+ /* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */
+ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert],
+ tailSegmentLen,
+ &listObjs[leadSegmentLen+numToDelete]);
}
+ newRep.storePtr->numUsed = origListLen + lenChange;
+ if (newRep.spanPtr) {
+ /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */
+ newRep.spanPtr->spanLength = newRep.storePtr->numUsed;
+ }
+ LISTREP_CHECK(&newRep);
+ ListObjReplaceRepAndInvalidate(listObj, &newRep);
+ return TCL_OK;
+ }
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- listRepPtr->refCount++;
+ /*
+ * Case (4) - unshared ListStore with sufficient room.
+ * After deleting elements, there will be a corresponding gap. If this
+ * gap does not match number of insertions, either the lead segment,
+ * or the tail segment, or both will have to be moved.
+ * The general strategy is to move the fewest number of elements. If
+ *
+ * TODO - what about appends to unshared ? Is below sufficiently optimal?
+ */
- elemPtrs = &listRepPtr->elements;
+ /* Following must hold for unshared listreps after ListRepFreeUnreferenced above */
+ LIST_ASSERT(origListLen == listRep.storePtr->numUsed);
+ LIST_ASSERT(origListLen == ListRepLength(&listRep));
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
- if (isShared) {
- /*
- * The old struct will remain in place; need new refCounts for the
- * new List struct references. Copy over only the surviving
- * elements.
- */
+ LIST_ASSERT((numToDelete + numToInsert) > 0);
- for (i=0; i < first; i++) {
- elemPtrs[i] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
- for (i = first + count, j = first + objc;
- j < numRequired; i++, j++) {
- elemPtrs[j] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[j]);
- }
+ /* Base of slot array holding the list elements */
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
- oldListRepPtr->refCount--;
+ /*
+ * Free up elements to be deleted. Before that, increment the ref counts
+ * for objects to be inserted in case there is overlap. T:listobj-11.1
+ */
+ if (numToInsert) {
+ /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
+ ObjArrayIncrRefs(insertObjs, 0, numToInsert);
+ }
+ if (numToDelete) {
+ /* T:listrep-1.{6,7,12:21},3.{19:41} */
+ ObjArrayDecrRefs(listObjs, first, numToDelete);
+ }
+
+ /*
+ * TODO - below the moves are optimized but this may result in needing a
+ * span allocation. Perhaps for small lists, it may be more efficient to
+ * just move everything up front and save on allocating a span.
+ */
+
+ /*
+ * Calculate shifts if necessary to accomodate insertions.
+ * NOTE: all indices are relative to listObjs which is not necessarily the
+ * start of the ListStore storage area.
+ *
+ * leadShift - how much to shift the lead segment
+ * tailShift - how much to shift the tail segment
+ * insertTarget - index where to insert.
+ */
+
+ if (lenChange == 0) {
+ /* T:listrep-1.{12,15,19},3.{23,28,33}. Exact fit */
+ leadShift = 0;
+ tailShift = 0;
+ } else if (lenChange < 0) {
+ /*
+ * More deletions than insertions. The gap after deletions is large
+ * enough for insertions. Move a segment depending on size.
+ */
+ if (leadSegmentLen > tailSegmentLen) {
+ /* Tail segment smaller. Insert after lead, move tail down */
+ /* T:listrep-1.{7,17,20},3.{21,2229,35} */
+ leadShift = 0;
+ tailShift = lenChange;
} else {
+ /* Lead segment smaller. Insert before tail, move lead up */
+ /* T:listrep-1.{6,13,16},3.{19,20,24,34} */
+ leadShift = -lenChange;
+ tailShift = 0;
+ }
+ } else {
+ LIST_ASSERT(lenChange > 0); /* Reminder */
+
+ /*
+ * We need to make room for the insertions. Again we have multiple
+ * possibilities. We may be able to get by just shifting one segment
+ * or need to shift both. In the former case, favor shifting the
+ * smaller segment.
+ */
+ int leadSpace = ListRepNumFreeHead(&listRep);
+ int tailSpace = ListRepNumFreeTail(&listRep);
+ int finalFreeSpace = leadSpace + tailSpace - lenChange;
+
+ LIST_ASSERT((leadSpace + tailSpace) >= lenChange);
+ if (leadSpace >= lenChange
+ && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) {
+ /* Move only lead to the front to make more room */
+ /* T:listrep-3.25,36,38, */
+ leadShift = -lenChange;
+ tailShift = 0;
/*
- * The old struct will be removed; use its inherited refCounts.
+ * Redistribute the remaining free space between the front and
+ * back if either there is no tail space left or if the
+ * entire list is the head anyways. This is an important
+ * optimization for further operations like further asymmetric
+ * insertions.
*/
-
- if (first > 0) {
- memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *));
- }
-
+ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) {
+ int postShiftLeadSpace = leadSpace - lenChange;
+ if (postShiftLeadSpace > (finalFreeSpace/2)) {
+ Tcl_Size extraShift = postShiftLeadSpace - (finalFreeSpace / 2);
+ leadShift -= extraShift;
+ tailShift = -extraShift; /* Move tail to the front as well */
+ }
+ } /* else T:listrep-3.{7,12,25,38} */
+ LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift);
+ } else if (tailSpace >= lenChange) {
+ /* Move only tail segment to the back to make more room. */
+ /* T:listrep-3.{8,10,11,14,26,27,30,32,37,39,41} */
+ leadShift = 0;
+ tailShift = lenChange;
/*
- * "Delete" count elements starting at first.
+ * See comments above. This is analogous.
*/
-
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = oldPtrs[j];
-
- TclDecrRefCount(victimPtr);
+ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) {
+ int postShiftTailSpace = tailSpace - lenChange;
+ if (postShiftTailSpace > (finalFreeSpace/2)) {
+ /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */
+ Tcl_Size extraShift = postShiftTailSpace - (finalFreeSpace / 2);
+ tailShift += extraShift;
+ leadShift = extraShift; /* Move head to the back as well */
+ }
}
-
+ LIST_ASSERT(tailShift <= tailSpace);
+ } else {
/*
- * Copy the elements after the last one removed, shifted to their
- * new locations.
+ * Both lead and tail need to be shifted to make room.
+ * Divide remaining free space equally between front and back.
*/
+ /* T:listrep-3.{9,13,31,40} */
+ LIST_ASSERT(leadSpace < lenChange);
+ LIST_ASSERT(tailSpace < lenChange);
- start = first + count;
- numAfterLast = numElems - start;
- if (numAfterLast > 0) {
- memcpy(elemPtrs + first + objc, oldPtrs + start,
- (size_t) numAfterLast * sizeof(Tcl_Obj *));
+ /*
+ * leadShift = leadSpace - (finalFreeSpace/2)
+ * Thus leadShift <= leadSpace
+ * Also,
+ * = leadSpace - (leadSpace + tailSpace - lenChange)/2
+ * = leadSpace/2 - tailSpace/2 + lenChange/2
+ * >= 0 because lenChange > tailSpace
+ */
+ leadShift = leadSpace - (finalFreeSpace / 2);
+ tailShift = lenChange - leadShift;
+ if (tailShift > tailSpace) {
+ /* Account for integer division errors */
+ leadShift += 1;
+ tailShift -= 1;
}
-
- ckfree(oldListRepPtr);
+ /*
+ * Following must be true because otherwise one of the previous
+ * if clauses would have been taken.
+ */
+ LIST_ASSERT(leadShift > 0 && leadShift < lenChange);
+ LIST_ASSERT(tailShift > 0 && tailShift < lenChange);
+ leadShift = -leadShift; /* Lead is actually shifted downward */
}
}
- /*
- * Insert the new elements into elemPtrs before "first".
- */
-
- for (i=0,j=first ; i<objc ; i++,j++) {
- elemPtrs[j] = objv[i];
+ /* Careful about order of moves! */
+ if (leadShift > 0) {
+ /* Will happen when we have to make room at bottom */
+ if (tailShift != 0 && tailSegmentLen != 0) {
+ /* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */
+ Tcl_Size tailStart = leadSegmentLen + numToDelete;
+ memmove(&listObjs[tailStart + tailShift],
+ &listObjs[tailStart],
+ tailSegmentLen * sizeof(Tcl_Obj *));
+ }
+ if (leadSegmentLen != 0) {
+ /* T:listrep-1.{3,6,16,18,21},3.{19,20,34} */
+ memmove(&listObjs[leadShift],
+ &listObjs[0],
+ leadSegmentLen * sizeof(Tcl_Obj *));
+ }
+ } else {
+ if (leadShift != 0 && leadSegmentLen != 0) {
+ /* T:listrep-3.{7,9,12,13,31,36,38,40} */
+ memmove(&listObjs[leadShift],
+ &listObjs[0],
+ leadSegmentLen * sizeof(Tcl_Obj *));
+ }
+ if (tailShift != 0 && tailSegmentLen != 0) {
+ /* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */
+ Tcl_Size tailStart = leadSegmentLen + numToDelete;
+ memmove(&listObjs[tailStart + tailShift],
+ &listObjs[tailStart],
+ tailSegmentLen * sizeof(Tcl_Obj *));
+ }
+ }
+ if (numToInsert) {
+ /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */
+ /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
+ memmove(&listObjs[leadSegmentLen + leadShift],
+ insertObjs,
+ numToInsert * sizeof(Tcl_Obj *));
}
- /*
- * Update the count of elements.
- */
-
- listRepPtr->elemCount = numRequired;
+ listRep.storePtr->firstUsed += leadShift;
+ listRep.storePtr->numUsed = origListLen + lenChange;
+ listRep.storePtr->flags = 0;
- /*
- * Invalidate and free any old string representation since it no longer
- * reflects the list's internal representation.
- */
+ if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
+ /* An unshared span record, re-use it, even if not required */
+ /* T:listrep-3.{2,3,7:14},3.{19:41} */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ } else {
+ /* Need a new span record */
+ if (listRep.storePtr->firstUsed == 0) {
+ /* T:listrep-1.{7,12,15,17,19,20} */
+ listRep.spanPtr = NULL;
+ } else {
+ /* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
+ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
+ listRep.storePtr->numUsed);
+ }
+ }
- TclInvalidateStringRep(listPtr);
+ LISTREP_CHECK(&listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1090,46 +2522,49 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * Implements the 'lindex' command when objc==3.
- *
- * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures
- * the argument format into required form while taking care to manage
- * shimmering so as to tend to keep the most useful internalreps
- * and/or avoid the most expensive conversions.
+ * This procedure handles the 'lindex' command when objc==3.
*
- * Value
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an error
+ * occurred. The returned object already includes one reference count for
+ * the pointer returned.
*
- * A pointer to the specified element, with its 'refCount' incremented, or
- * NULL if an error occurred.
+ * Side effects:
+ * None.
*
- * Notes
+ * Notes:
+ * This procedure is implemented entirely as a wrapper around
+ * TclLindexFlat. All it does is reconfigure the argument format into the
+ * form required by TclLindexFlat, while taking care to manage shimmering
+ * in such a way that we tend to keep the most useful internalreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* List being unpacked. */
- Tcl_Obj *argPtr) /* Index or index list. */
+ Tcl_Obj *listObj, /* List being unpacked. */
+ Tcl_Obj *argObj) /* Index or index list. */
{
-
- int index; /* Index into the list. */
+ Tcl_Size index; /* Index into the list. */
Tcl_Obj *indexListCopy;
+ Tcl_Obj **indexObjs;
+ Tcl_Size numIndexObjs;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
- * shimmering; see TIP#22 and TIP#33 for the details.
+ * shimmering; if internal rep is already a list do not shimmer it.
+ * see TIP#22 and TIP#33 for the details.
*/
-
- if (argPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
+ if (!TclHasInternalRep(argObj, &tclListType)
+ && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index)
+ == TCL_OK) {
/*
* argPtr designates a single index.
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
@@ -1144,62 +2579,83 @@ TclLindexList(
* implementation does not.
*/
- indexListCopy = TclListObjCopy(NULL, argPtr);
+ indexListCopy = TclListObjCopy(NULL, argObj);
if (indexListCopy == NULL) {
/*
- * argPtr designates something that is neither an index nor a
- * well-formed list. Report the error via TclLindexFlat.
+ * The argument is neither an index nor a well-formed list.
+ * Report the error via TclLindexFlat.
+ * TODO - This is as original. why not directly return an error?
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
- {
- int indexCount = -1; /* Size of the array of list indices. */
- Tcl_Obj **indices = NULL; /* Array of list indices. */
-
- TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
- listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
- }
+ ListObjGetElements(indexListCopy, numIndexObjs, indexObjs);
+ listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
- return listPtr;
+ return listObj;
}
/*
*----------------------------------------------------------------------
*
- * TclLindexFlat --
- *
- * The core of the 'lindex' command, with all index
- * arguments presented as a flat list.
+ * TclLindexFlat --
*
- * Value
+ * This procedure is the core of the 'lindex' command, with all index
+ * arguments presented as a flat list.
*
- * A pointer to the object extracted, with its 'refCount' incremented, or
- * NULL if an error occurred. Thus, the calling code will usually do
- * something like:
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an error
+ * occurred. The returned object already includes one reference count for
+ * the pointer returned.
*
- * Tcl_SetObjResult(interp, result);
- * Tcl_DecrRefCount(result);
+ * Side effects:
+ * None.
*
+ * Notes:
+ * The reference count of the returned object includes one reference
+ * corresponding to the pointer returned. Thus, the calling code will
+ * usually do something like:
+ * Tcl_SetObjResult(interp, result);
+ * Tcl_DecrRefCount(result);
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLindexFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Tcl object representing the list. */
- int indexCount, /* Count of indices. */
+ Tcl_Obj *listObj, /* Tcl object representing the list. */
+ Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
- int i;
+ Tcl_Size i;
+
+ /* Handle ArithSeries as special case */
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ Tcl_Size listLen = TclArithSeriesObjLength(listObj);
+ Tcl_Size index;
+ Tcl_Obj *elemObj = NULL;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
+ &index) == TCL_OK) {
+ }
+ if (i==0) {
+ elemObj = TclArithSeriesObjIndex(NULL, listObj, index);
+ } else if (index > 0) {
+ /* ArithSeries cannot be a list of lists */
+ Tcl_DecrRefCount(elemObj);
+ TclNewObj(elemObj);
+ break;
+ }
+ }
+ Tcl_IncrRefCount(elemObj);
+ return elemObj;
+ }
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
- for (i=0 ; i<indexCount && listPtr ; i++) {
- int index, listLen = 0;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ Tcl_Size index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
@@ -1208,18 +2664,16 @@ TclLindexFlat(
* while we are still using it. See test lindex-8.4.
*/
- sublistCopy = TclListObjCopy(interp, listPtr);
- Tcl_DecrRefCount(listPtr);
- listPtr = NULL;
+ sublistCopy = TclListObjCopy(interp, listObj);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
if (sublistCopy == NULL) {
- /*
- * The sublist is not a list at all => error.
- */
-
+ /* The sublist is not a list at all => error. */
break;
}
- TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
+ LIST_ASSERT_TYPE(sublistCopy);
+ ListObjGetElements(sublistCopy, listLen, elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
@@ -1230,26 +2684,24 @@ TclLindexFlat(
*/
while (++i < indexCount) {
- if (TclGetIntForIndexM(interp, indexArray[i], -1, &index)
+ if (TclGetIntForIndexM(
+ interp, indexArray[i], ListSizeT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
- TclNewObj(listPtr);
+ TclNewObj(listObj);
} else {
- /*
- * Extract the pointer to the appropriate element.
- */
-
- listPtr = elemPtrs[index];
+ /* Extract the pointer to the appropriate element. */
+ listObj = elemPtrs[index];
}
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
}
Tcl_DecrRefCount(sublistCopy);
}
- return listPtr;
+ return listObj;
}
/*
@@ -1257,31 +2709,38 @@ TclLindexFlat(
*
* TclLsetList --
*
- * The core of [lset] when objc == 4. Objv[2] may be either a
+ * Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
+ * It also handles 'lpop' when given a NULL value.
*
- * Implemented entirely as a wrapper around 'TclLindexFlat', as described
- * for 'TclLindexList'.
+ * Results:
+ * Returns the new value of the list variable, or NULL if there was an
+ * error. The returned object includes one reference count for the
+ * pointer returned.
*
- * Value
+ * Side effects:
+ * None.
*
- * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if
- * there was an error.
+ * Notes:
+ * This procedure is implemented entirely as a wrapper around
+ * TclLsetFlat. All it does is reconfigure the argument format into the
+ * form required by TclLsetFlat, while taking care to manage shimmering
+ * in such a way that we tend to keep the most useful internalreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Pointer to the list being modified. */
- Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *listObj, /* Pointer to the list being modified. */
+ Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */
+ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int indexCount = 0; /* Number of indices in the index list. */
+ Tcl_Size 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 *retValueObj; /* Pointer to the list to be returned. */
+ Tcl_Size index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
/*
@@ -1290,35 +2749,33 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- if (indexArgPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
- /*
- * indexArgPtr designates a single index.
- */
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
-
+ if (!TclHasInternalRep(indexArgObj, &tclListType)
+ && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index)
+ == TCL_OK) {
+ /* indexArgPtr designates a single index. */
+ /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
+ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
- indexListCopy = TclListObjCopy(NULL, indexArgPtr);
+ indexListCopy = TclListObjCopy(NULL, indexArgObj);
if (indexListCopy == NULL) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
+ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
- TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
+ LIST_ASSERT_TYPE(indexListCopy);
+ ListObjGetElements(indexListCopy, indexCount, indices);
/*
* Let TclLsetFlat handle the actual lset'ting.
*/
- retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);
+ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
Tcl_DecrRefCount(indexListCopy);
- return retValuePtr;
+ return retValueObj;
}
/*
@@ -1327,105 +2784,108 @@ TclLsetList(
* TclLsetFlat --
*
* Core engine of the 'lset' command.
- *
- * Value
- *
- * The resulting list
- *
- * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not
- * duplicated, its 'refCount' is incremented. The reference count of
- * an unduplicated object is therefore 2 (one for the returned pointer
- * and one for the variable that holds it). The reference count of a
- * duplicate object is 1, reflecting that result is the only active
- * reference. The caller is expected to store the result in the
- * variable and decrement its reference count. (INST_STORE_* does
- * exactly this.)
- *
- * NULL
- *
- * An error occurred. If 'listPtr' was duplicated, the reference
- * count on the duplicate is decremented so that it is 0, causing any
- * memory allocated by this function to be freed.
- *
- *
- * Effect
- *
- * On entry, the reference count of 'listPtr' does not reflect any
- * references held on the stack. The first action of this function is to
- * determine whether 'listPtr' is shared and to create a duplicate
- * unshared copy if it is. The reference count of the duplicate is
- * incremented. At this point, the reference count is 1 in either case so
- * that the object is considered unshared.
- *
- * The unshared list is altered directly to produce the result.
- * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string
- * representations must be spoilt by threading via 'ptr2' of the
- * two-pointer internal representation. On entry to 'TclLsetFlat', the
- * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
- * Tcl_Obj that has been modified is set to NULL.
+ * It also handles 'lpop' when given a NULL value.
+ *
+ * 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.
+ *
+ * Side effects:
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack. The first action of this function is
+ * to determine whether the object is shared, and to duplicate it if it
+ * is. The reference count of the duplicate is incremented. At this
+ * point, the reference count will be 1 for either case, so that the
+ * object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this
+ * dismisses any memory that was allocated by this function.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is done
+ * to a reference count of the duplicate. Now the reference count of an
+ * unduplicated object is 2 (the returned pointer, plus the one stored in
+ * the variable). The reference count of a duplicate object is 1,
+ * reflecting that the returned pointer is the only active reference. The
+ * caller is expected to store the returned value back in the variable
+ * and decrement its reference count. (INST_STORE_* does exactly this.)
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Pointer to the list being modified. */
- int indexCount, /* Number of index args. */
+ Tcl_Obj *listObj, /* Pointer to the list being modified. */
+ Tcl_Size indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int index, result, len;
- Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+ Tcl_Size index, len;
+ int result;
+ Tcl_Obj *subListObj, *retValueObj;
+ Tcl_Obj *pendingInvalidates[10];
+ Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
+ Tcl_Size numPendingInvalidates = 0;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
+ * [lpop] does not use this but protect for NULL valueObj just in case.
*/
if (indexCount == 0) {
- Tcl_IncrRefCount(valuePtr);
- return valuePtr;
+ if (valueObj != NULL) {
+ Tcl_IncrRefCount(valueObj);
+ }
+ return valueObj;
}
/*
* 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
+ * 1) we have not yet confirmed listObj 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
+ * this routine to return NULL, will leave the string rep of listObj and
* all elements to be unchanged.
*/
- subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+ subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj;
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
- retValuePtr = subListPtr;
- chainPtr = NULL;
+ retValueObj = subListObj;
result = TCL_OK;
+ /* Allocate if static array for pending invalidations is too small */
+ if (indexCount
+ > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) {
+ pendingInvalidatesPtr =
+ (Tcl_Obj **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr));
+ }
+
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
*/
do {
- int elemCount;
+ Tcl_Size elemCount;
Tcl_Obj *parentList, **elemPtrs;
/*
* Check for the possible error conditions...
*/
- if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
- != TCL_OK) {
+ if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs)
+ != TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
result = TCL_ERROR;
break;
@@ -1437,21 +2897,27 @@ TclLsetFlat(
*/
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
- != TCL_OK) {
+ != TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
- indexArray++;
+ indexArray++; /* Why bother with this increment? TBD */
break;
}
indexArray++;
- if (index < 0 || index > elemCount) {
+ if (index < 0 || index > elemCount
+ || (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
- "BADINDEX", NULL);
+ Tcl_ObjPrintf("index \"%s\" out of range",
+ Tcl_GetString(indexArray[-1])));
+ Tcl_SetErrorCode(interp,
+ "TCL",
+ "VALUE",
+ "INDEX"
+ "OUTOFRANGE",
+ NULL);
}
result = TCL_ERROR;
break;
@@ -1459,115 +2925,129 @@ TclLsetFlat(
/*
* 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.
+ * 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.
*/
if (--indexCount) {
- parentList = subListPtr;
+ parentList = subListObj;
if (index == elemCount) {
- TclNewObj(subListPtr);
+ TclNewObj(subListObj);
} else {
- subListPtr = elemPtrs[index];
+ subListObj = elemPtrs[index];
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
+ if (Tcl_IsShared(subListObj)) {
+ subListObj = Tcl_DuplicateObj(subListObj);
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its internalrep with other
- * Tcl_Obj's. Dealing with the shared internalrep case can cause
- * subListPtr to become shared again, so detect that case and make
- * and store another copy.
+ * Tcl_Obj's. Dealing with the shared internalrep case can
+ * cause subListObj to become shared again, so detect that case
+ * and make and store another copy.
*/
if (index == elemCount) {
- Tcl_ListObjAppendElement(NULL, parentList, subListPtr);
+ Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ TclListObjSetElement(NULL, parentList, index, subListObj);
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ if (Tcl_IsShared(subListObj)) {
+ subListObj = Tcl_DuplicateObj(subListObj);
+ TclListObjSetElement(NULL, parentList, index, subListObj);
}
/*
- * 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 internalrep 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 valueObj
+ * 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 internalrep surgery) so we can spoil them at that
+ * time.
*/
- parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
- chainPtr = parentList;
+ pendingInvalidatesPtr[numPendingInvalidates] = parentList;
+ ++numPendingInvalidates;
}
} 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.
+ * we're ready to store valueObj. On success, we need to invalidate
+ * the string representations of intermediate lists whose contained
+ * list element would have changed.
*/
+ if (result == TCL_OK) {
+ while (numPendingInvalidates > 0) {
+ Tcl_Obj *objPtr;
- while (chainPtr) {
- Tcl_Obj *objPtr = chainPtr;
+ --numPendingInvalidates;
+ objPtr = pendingInvalidatesPtr[numPendingInvalidates];
- if (result == TCL_OK) {
- /*
- * We're going to store valuePtr, so spoil string reps of all
- * containing lists.
- */
-
- TclInvalidateStringRep(objPtr);
+ if (result == TCL_OK) {
+ /*
+ * We're going to store valueObj, so spoil string reps of all
+ * containing lists.
+ * TODO - historically, the storing of the internal rep was done
+ * because the ptr2 field of the internal rep was used to chain
+ * objects whose string rep needed to be invalidated. Now this
+ * is no longer the case, so replacing of the internal rep
+ * should not be needed. The TclInvalidateStringRep should
+ * suffice. Formulate a test case before changing.
+ */
+ ListRep objInternalRep;
+ TclListObjGetRep(NULL, objPtr, &objInternalRep);
+ ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep);
+ }
}
-
- /*
- * Clear away our internalrep surgery mess.
- */
-
- chainPtr = objPtr->internalRep.twoPtrValue.ptr2;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
+ if (pendingInvalidatesPtr != pendingInvalidates)
+ ckfree(pendingInvalidatesPtr);
+
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
- if (retValuePtr != listPtr) {
- Tcl_DecrRefCount(retValuePtr);
+ if (retValueObj != listObj) {
+ Tcl_DecrRefCount(retValueObj);
}
return NULL;
}
/*
- * Store valuePtr in proper sublist and return. The -1 is to avoid a
+ * Store valueObj in proper sublist and return. The -1 is to avoid a
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
len = -1;
- TclListObjLength(NULL, subListPtr, &len);
- if (index == len) {
- Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
+ TclListObjLengthM(NULL, subListObj, &len);
+ if (valueObj == NULL) {
+ /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */
+ Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL);
+ } else if (index == len) {
+ /* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
+ Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
- TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ /* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
+ TclListObjSetElement(NULL, subListObj, index, valueObj);
+ TclInvalidateStringRep(subListObj);
}
- TclInvalidateStringRep(subListPtr);
- Tcl_IncrRefCount(retValuePtr);
- return retValuePtr;
+ Tcl_IncrRefCount(retValueObj);
+ return retValueObj;
}
/*
@@ -1575,146 +3055,91 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value.
- *
- * It is the caller's responsibility to invalidate the string
- * representation of the 'listPtr'.
- *
- * Value
- *
- * TCL_OK
+ * Set a single element of a list to a specified value
*
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' does not refer to a list object and cannot be converted
- * to one. An error message will be left in the interpreter result if
- * interp is not NULL.
- *
- * TCL_ERROR
- *
- * An index designates an element outside the range [0..listLength-1],
- * where 'listLength' is the count of elements in the list object
- * designated by 'listPtr'. An error message is left in the
- * interpreter result.
- *
- * Effect
- *
- * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If
- * 'listPtr' is not already of type 'tclListType', it is converted and the
- * internal representation is unshared. The 'refCount' of the element at
- * 'index' is decremented and replaced in the list with the 'valuePtr',
- * whose 'refCount' in turn is incremented.
+ * Results:
+ * The return value is normally TCL_OK. If listObj does not refer to a
+ * list object and cannot be converted to one, TCL_ERROR is returned and
+ * an error message will be left in the interpreter result if interp is
+ * not NULL. Similarly, if index designates an element outside the range
+ * [0..listLength-1], where listLength is the count of elements in the
+ * list object designated by listObj, TCL_ERROR is returned and an error
+ * message is left in the interpreter result.
*
+ * Side effects:
+ * Tcl_Panic if listObj designates a shared object. Otherwise, attempts
+ * to convert it to a list with a non-shared internal rep. Decrements the
+ * ref count of the object at the specified index within the list,
+ * replaces with the object designated by valueObj, and increments the
+ * ref count of the replacement object.
*
*----------------------------------------------------------------------
*/
-
int
TclListObjSetElement(
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting
* if not NULL. */
- Tcl_Obj *listPtr, /* List object in which element should be
+ Tcl_Obj *listObj, /* List object in which element should be
* stored. */
- int index, /* Index of element to store. */
- Tcl_Obj *valuePtr) /* Tcl object to store in the designated list
+ Tcl_Size index, /* Index of element to store. */
+ Tcl_Obj *valueObj) /* Tcl object to store in the designated list
* element. */
{
- List *listRepPtr; /* Internal representation of the list being
- * modified. */
- Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
- int elemCount; /* Number of elements in the list. */
+ ListRep listRep;
+ Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
+ Tcl_Size elemCount; /* Number of elements in the list. */
- /*
- * Ensure that the listPtr parameter designates an unshared list.
- */
+ /* Ensure that the listObj parameter designates an unshared list. */
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- if (listPtr->typePtr != &tclListType) {
- int result;
- if (listPtr->bytes == tclEmptyStringRep) {
- 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;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
}
- listRepPtr = ListRepPtr(listPtr);
- elemCount = listRepPtr->elemCount;
-
- /*
- * Ensure that the index is in bounds.
- */
+ elemCount = ListRepLength(&listRep);
+ /* Ensure that the index is in bounds. */
if (index<0 || index>=elemCount) {
if (interp != NULL) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "index \"%d\" out of range", index));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
+ "OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
/*
- * If the internal rep is shared, replace it with an unshared copy.
+ * Note - garbage collect this only AFTER checking indices above.
+ * Do not want to modify listrep and then not store it back in listObj.
*/
+ ListRepFreeUnreferenced(&listRep);
- if (listRepPtr->refCount > 1) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
- List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);
-
- if (newPtr == NULL) {
- newPtr = AttemptNewList(interp, elemCount, NULL);
- if (newPtr == NULL) {
- return TCL_ERROR;
- }
- }
- newPtr->refCount++;
- newPtr->elemCount = elemCount;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
-
- dst = &newPtr->elements;
- while (elemCount--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
- }
-
- listRepPtr->refCount--;
+ /* Replace a shared internal rep with an unshared copy */
+ if (listRep.storePtr->refCount > 1) {
+ ListRep newInternalRep;
+ /* T:listrep-2.{10,13,16}.1 */
+ /* TODO - leave extra space? */
+ ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL);
+ listRep = newInternalRep;
+ } /* else T:listrep-1.{12.1,15.1,19.1} */
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;
- }
- elemPtrs = &listRepPtr->elements;
+ /* Retrieve element array AFTER potential cloning above */
+ ListRepElements(&listRep, elemCount, elemPtrs);
/*
- * Add a reference to the new list element.
+ * Add a reference to the new list element and remove from old before
+ * replacing it. Order is important!
*/
-
- Tcl_IncrRefCount(valuePtr);
-
- /*
- * Remove a reference from the old list element.
- */
-
+ Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
+ elemPtrs[index] = valueObj;
- /*
- * Stash the new object in the list.
- */
-
- elemPtrs[index] = valuePtr;
+ /* Internal rep may be cloned so replace */
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1724,35 +3149,34 @@ TclListObjSetElement(
*
* FreeListInternalRep --
*
- * Deallocate the storage associated with the internal representation of a
- * a list object.
+ * Deallocate the storage associated with a list object's internal
+ * representation.
*
- * Effect
+ * Results:
+ * None.
*
- * The storage for the internal 'List' pointer of 'listPtr' is freed, the
- * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount'
- * of each element of the list is decremented.
+ * Side effects:
+ * Frees listPtr's List* internal representation, if no longer shared.
+ * May decrement the ref counts of element objects, which may free them.
*
*----------------------------------------------------------------------
*/
-
static void
FreeListInternalRep(
- Tcl_Obj *listPtr) /* List object with internal rep to free. */
+ Tcl_Obj *listObj) /* List object with internal rep to free. */
{
- List *listRepPtr = ListRepPtr(listPtr);
-
- if (listRepPtr->refCount-- <= 1) {
- Tcl_Obj **elemPtrs = &listRepPtr->elements;
- int i, numElems = listRepPtr->elemCount;
-
- for (i = 0; i < numElems; i++) {
- Tcl_DecrRefCount(elemPtrs[i]);
- }
- ckfree(listRepPtr);
+ ListRep listRep;
+
+ ListObjGetRep(listObj, &listRep);
+ if (listRep.storePtr->refCount-- <= 1) {
+ ObjArrayDecrRefs(
+ listRep.storePtr->slots,
+ listRep.storePtr->firstUsed, listRep.storePtr->numUsed);
+ ckfree(listRep.storePtr);
+ }
+ if (listRep.spanPtr) {
+ ListSpanDecrRefs(listRep.spanPtr);
}
-
- listPtr->typePtr = NULL;
}
/*
@@ -1760,24 +3184,25 @@ FreeListInternalRep(
*
* DupListInternalRep --
*
- * Initialize the internal representation of a list 'Tcl_Obj' to share the
+ * Initialize the internal representation of a list Tcl_Obj to share the
* internal representation of an existing list object.
*
- * Effect
+ * Results:
+ * None.
*
- * The 'refCount' of the List internal rep is incremented.
+ * Side effects:
+ * The reference count of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
-
static void
DupListInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ Tcl_Obj *srcObj, /* Object with internal rep to copy. */
+ Tcl_Obj *copyObj) /* Object with internal rep to set. */
{
- List *listRepPtr = ListRepPtr(srcPtr);
-
- ListSetInternalRep(copyPtr, listRepPtr);
+ ListRep listRep;
+ ListObjGetRep(srcObj, &listRep);
+ ListObjOverwriteRep(copyObj, &listRep);
}
/*
@@ -1785,31 +3210,26 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Convert any object to a list.
+ * Attempt to generate a list internal form for the Tcl object "objPtr".
*
- * Value
- *
- * TCL_OK
- *
- * Success. The internal representation of 'objPtr' is set, and the type
- * of 'objPtr' is 'tclListType'.
- *
- * TCL_ERROR
- *
- * An error occured during conversion. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * Results:
+ * The return value is TCL_OK or TCL_ERROR. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
*
+ * Side effects:
+ * If no error occurs, a list is stored as "objPtr"s internal
+ * representation.
*
*----------------------------------------------------------------------
*/
-
static int
SetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
- List *listRepPtr;
Tcl_Obj **elemPtrs;
+ ListRep listRep;
/*
* Dictionaries are a special case; they have a string representation such
@@ -1819,10 +3239,11 @@ SetListFromAny(
* describe duplicate keys).
*/
- if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
+ if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
- int done, size;
+ int done;
+ Tcl_Size size;
/*
* Create the new list representation. Note that we do not need to do
@@ -1834,17 +3255,22 @@ SetListFromAny(
*/
Tcl_DictObjSize(NULL, objPtr, &size);
- listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
- if (!listRepPtr) {
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? 2 * size : 1, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- listRepPtr->elemCount = 2 * size;
- /*
- * Populate the list representation.
- */
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+ LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
+
+ listRep.storePtr->numUsed = 2 * size;
- elemPtrs = &listRepPtr->elements;
+ /* Populate the list representation. */
+
+ elemPtrs = listRep.storePtr->slots;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
@@ -1853,8 +3279,36 @@ SetListFromAny(
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
+ } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ /*
+ * Convertion from Arithmetic Series is a special case
+ * because it can be done an order of magnitude faster
+ * and may occur frequently.
+ */
+ Tcl_Size j, size = TclArithSeriesObjLength(objPtr);
+
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? size : 1, NULL, &listRep)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+ LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
+
+ listRep.storePtr->numUsed = size;
+ elemPtrs = listRep.storePtr->slots;
+ for (j = 0; j < size; j++) {
+ elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j);
+ if (elemPtrs[j] == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
} else {
- int estCount, length;
+ Tcl_Size estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
@@ -1865,56 +3319,77 @@ SetListFromAny(
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
- listRepPtr = AttemptNewList(interp, estCount, NULL);
- if (listRepPtr == NULL) {
+ /* TODO - allocate additional space? */
+ if (ListRepInitAttempt(interp, estCount, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- elemPtrs = &listRepPtr->elements;
- /*
- * Each iteration, parse and store a list element.
- */
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+
+ elemPtrs = listRep.storePtr->slots;
+
+ /* Each iteration, parse and store a list element. */
while (nextElem < limit) {
const char *elemStart;
- int elemSize, literal;
+ char *check;
+ Tcl_Size elemSize;
+ int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
- while (--elemPtrs >= &listRepPtr->elements) {
+fail:
+ while (--elemPtrs >= listRep.storePtr->slots) {
Tcl_DecrRefCount(*elemPtrs);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRep.storePtr);
return TCL_ERROR;
}
if (elemStart == limit) {
break;
}
- /* TODO: replace panic with error on alloc failure? */
- if (literal) {
- TclNewStringObj(*elemPtrs, elemStart, elemSize);
- } else {
- TclNewObj(*elemPtrs);
- (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1);
- (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart,
- (*elemPtrs)->bytes);
+ TclNewObj(*elemPtrs);
+ TclInvalidateStringRep(*elemPtrs);
+ check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL,
+ elemSize);
+ if (elemSize && check == NULL) {
+ MemoryAllocationError(interp, elemSize);
+ goto fail;
+ }
+ if (!literal) {
+ Tcl_InitStringRep(*elemPtrs, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, check));
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
- listRepPtr->elemCount = elemPtrs - &listRepPtr->elements;
+ listRep.storePtr->numUsed =
+ elemPtrs - listRep.storePtr->slots;
}
+ LISTREP_CHECK(&listRep);
+
/*
- * Free the old internalRep before setting the new one. We do this as late
+ * Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
- * Tcl_GetStringFromObj, to use that old internalRep.
+ * Tcl_GetStringFromObj, to use the old internalRep.
+ */
+
+ /*
+ * Note old string representation NOT to be invalidated.
+ * So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
+ * IncrRefs so do not use ListObjOverwriteRep
*/
+ ListRepIncrRefs(&listRep);
+ TclFreeInternalRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
+ objPtr->typePtr = &tclListType;
- TclFreeIntRep(objPtr);
- ListSetInternalRep(objPtr, listRepPtr);
return TCL_OK;
}
@@ -1923,66 +3398,72 @@ SetListFromAny(
*
* UpdateStringOfList --
*
- * Update the string representation for a list object.
- *
- * Any previously-exising string representation is not invalidated, so
- * storage is lost if this has not been taken care of.
+ * Update the string representation for a list object. Note: This
+ * function does not invalidate an existing old string rep so storage
+ * will be lost if this has not already been done.
*
- * Effect
+ * Results:
+ * None.
*
- * The string representation of 'listPtr' is set to the resulting string.
- * This string will be empty if the list has no elements. It is assumed
- * that the list internal representation is not NULL.
+ * Side effects:
+ * The object's string is set to a valid string that results from the
+ * list-to-string conversion. This string will be empty if the list has
+ * no elements. The list internal representation should not be NULL and
+ * we assume it is not NULL.
*
*----------------------------------------------------------------------
*/
-
static void
UpdateStringOfList(
- Tcl_Obj *listPtr) /* List object with string rep to update. */
+ Tcl_Obj *listObj) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- List *listRepPtr = ListRepPtr(listPtr);
- int numElems = listRepPtr->elemCount;
- int i, length;
- unsigned int bytesNeeded = 0;
- const char *elem;
+ Tcl_Size numElems, i, length;
+ TCL_HASH_TYPE bytesNeeded = 0;
+ const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
+ ListRep listRep;
+
+ ListObjGetRep(listObj, &listRep);
+ LISTREP_CHECK(&listRep);
+
+ ListRepElements(&listRep, numElems, elemPtrs);
/*
* Mark the list as being canonical; although it will now have a string
* rep, it is one we derived through proper "canonical" quoting and so
* it's known to be free from nasties relating to [concat] and [eval].
+ * However, we only do this if this is not a spanned list. Marking the
+ * storage canonical for a spanned list make ALL lists using the storage
+ * canonical which is not right. (Consider a list generated from a
+ * string and then this function called for a spanned list generated
+ * from it). On the other hand, a spanned list is always canonical
+ * (never generated from a string) so it does not have to be explicitly
+ * marked as such. The ListObjIsCanonical macro takes this into account.
+ * See the comments there.
*/
+ if (listRep.spanPtr == NULL) {
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */
+ listRep.storePtr->flags |= LISTSTORE_CANONICAL;
+ }
- listRepPtr->canonicalFlag = 1;
-
- /*
- * Handle empty list case first, so rest of the routine is simpler.
- */
+ /* Handle empty list case first, so rest of the routine is simpler. */
if (numElems == 0) {
- listPtr->bytes = tclEmptyStringRep;
- listPtr->length = 0;
+ Tcl_InitStringRep(listObj, NULL, 0);
return;
}
- /*
- * Pass 1: estimate space, gather flags.
- */
+ /* Pass 1: estimate space, gather flags. */
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- /*
- * We know numElems <= LIST_MAX, so this is safe.
- */
-
- flagPtr = ckalloc(numElems);
+ /* We know numElems <= LIST_MAX, so this is safe. */
+ flagPtr = (char *)ckalloc(numElems);
}
- elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
@@ -1994,46 +3475,82 @@ UpdateStringOfList(
if (bytesNeeded + numElems > INT_MAX + 1U) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- bytesNeeded += numElems;
+ bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
- /*
- * We used to set the string length here, relying on a presumed
- * guarantee that the number of bytes TclScanElement() calls reported
- * to be needed was a precise count and not an over-estimate, so long
- * as the same flag values were passed to TclConvertElement().
- *
- * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused
- * that guarantee to fail. Rather than trust there are no more bugs,
- * we set the length after the loop based on what was actually written,
- * an not on what was predicted.
- *
- listPtr->length = bytesNeeded - 1;
- *
- */
-
- listPtr->bytes = ckalloc(bytesNeeded);
- dst = listPtr->bytes;
+ start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
+ TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
- dst[-1] = '\0';
- /* Here is the safe setting of the string length. */
- listPtr->length = dst - 1 - listPtr->bytes;
+ /* Set the string length to what was actually written, the safe choice */
+ (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(flagPtr);
}
}
+
/*
+ *------------------------------------------------------------------------
+ *
+ * TclListTestObj --
+ *
+ * Returns a list object with a specific internal rep and content.
+ * Used specifically for testing so span can be controlled explicitly.
+ *
+ * Results:
+ * Pointer to the Tcl_Obj containing the list.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace)
+{
+ ListRep listRep;
+ size_t capacity;
+ Tcl_Obj *listObj;
+
+ TclNewObj(listObj);
+
+ /* Only a test object so ignoring overflow checks */
+ capacity = length + leadingSpace + endSpace;
+ if (capacity == 0) {
+ return listObj;
+ }
+ if (capacity > LIST_MAX) {
+ return NULL;
+ }
+
+ ListRepInit(capacity, NULL, 0, &listRep);
+
+ ListStore *storePtr = listRep.storePtr;
+ size_t i;
+ for (i = 0; i < length; ++i) {
+ TclNewUIntObj(storePtr->slots[i + leadingSpace], i);
+ Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]);
+ }
+ storePtr->firstUsed = leadingSpace;
+ storePtr->numUsed = length;
+ if (leadingSpace != 0) {
+ listRep.spanPtr = ListSpanNew(leadingSpace, length);
+ }
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
+ return listObj;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 35c54be..0c2c545 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -7,8 +7,8 @@
* general hashtable implementation of Tcl hash tables that appears in
* tclHash.c.
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2004 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.
@@ -104,7 +104,7 @@ TclDeleteLiteralTable(
{
LiteralEntry *entryPtr, *nextPtr;
Tcl_Obj *objPtr;
- int i;
+ size_t i;
/*
* Release remaining literals in the table. Note that releasing a literal
@@ -114,6 +114,8 @@ TclDeleteLiteralTable(
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
+#else
+ (void)interp;
#endif /*TCL_COMPILE_DEBUG*/
/*
@@ -174,7 +176,7 @@ TclDeleteLiteralTable(
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
- char *bytes, /* The start of the string. Note that this is
+ const 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
@@ -186,7 +188,7 @@ TclCreateLiteral(
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
- int globalHash;
+ unsigned int globalHash;
Tcl_Obj *objPtr;
/*
@@ -209,7 +211,7 @@ TclCreateLiteral(
*/
int objLength;
- char *objBytes = TclGetStringFromObj(objPtr, &objLength);
+ const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
@@ -227,7 +229,9 @@ TclCreateLiteral(
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
- globalPtr->refCount++;
+ if (globalPtr->refCount != TCL_INDEX_NONE) {
+ globalPtr->refCount++;
+ }
return objPtr;
}
}
@@ -240,20 +244,22 @@ TclCreateLiteral(
}
/*
- * The literal is new to the interpreter. Add it to the global literal
- * table.
+ * The literal is new to the interpreter.
*/
TclNewObj(objPtr);
if ((flags & LITERAL_ON_HEAP)) {
- objPtr->bytes = bytes;
+ objPtr->bytes = (char *) bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+ /* Should the new literal be shared globally? */
+
if ((flags & LITERAL_UNSHARED)) {
/*
+ * No, do *not* add it the global literal table
* Make clear, that no global value is returned
*/
if (globalPtrPtr != NULL) {
@@ -262,6 +268,9 @@ TclCreateLiteral(
return objPtr;
}
+ /*
+ * Yes, add it to the global literal table.
+ */
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -291,7 +300,8 @@ TclCreateLiteral(
TclVerifyGlobalLiteralTable(iPtr);
{
LiteralEntry *entryPtr;
- int found, i;
+ int found;
+ size_t i;
found = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
@@ -381,7 +391,7 @@ int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
- char *bytes, /* Points to string for which to find or
+ const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length, /* Number of bytes in the string. If < 0, the
@@ -393,13 +403,14 @@ TclRegisterLiteral(
* the literal should not be shared accross
* namespaces. */
{
- CompileEnv *envPtr = ePtr;
+ CompileEnv *envPtr = (CompileEnv *)ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
unsigned hash;
- int localHash, objIndex, new;
+ unsigned int localHash;
+ int objIndex, isNew;
Namespace *nsPtr;
if (length < 0) {
@@ -453,12 +464,12 @@ TclRegisterLiteral(
*/
globalPtr = NULL;
- objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
+ objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr != NULL && globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount + 1 < 2) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -543,7 +554,8 @@ TclHideLiteral(
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
- int localHash, length;
+ unsigned int localHash;
+ int length;
const char *bytes;
Tcl_Obj *newObjPtr;
@@ -562,7 +574,7 @@ TclHideLiteral(
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
- localHash = (HashString(bytes, length) & localTablePtr->mask);
+ localHash = HashString(bytes, length) & localTablePtr->mask;
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
@@ -618,7 +630,7 @@ TclAddLiteralObj(
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
- lPtr->refCount = -1; /* i.e., unused */
+ lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
@@ -680,7 +692,8 @@ AddLocalLiteralEntry(
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
- int length, found, i;
+ int length, found;
+ size_t i;
found = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
@@ -693,7 +706,7 @@ AddLocalLiteralEntry(
}
if (!found) {
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : length), bytes);
}
@@ -734,15 +747,15 @@ ExpandLocalLiteralArray(
*/
LiteralTable *localTablePtr = &envPtr->localLitTable;
- int currElems = envPtr->literalArrayNext;
+ size_t currElems = envPtr->literalArrayNext;
size_t currBytes = (currElems * sizeof(LiteralEntry));
LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
LiteralEntry *newArrayPtr;
- int i;
- unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX;
+ size_t i;
+ size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX;
if (currBytes == newSize) {
- Tcl_Panic("max size of Tcl literal array (%d literals) exceeded",
+ Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
@@ -815,7 +828,8 @@ TclReleaseLiteral(
LiteralTable *globalTablePtr;
LiteralEntry *entryPtr, *prevPtr;
const char *bytes;
- int length, index;
+ int length;
+ unsigned int index;
if (iPtr == NULL) {
goto done;
@@ -834,15 +848,13 @@ TclReleaseLiteral(
for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
- entryPtr->refCount--;
-
/*
* If the literal is no longer being used by any ByteCode, delete
* the entry then remove the reference corresponding to the global
* literal table entry (decrement the ref count of the object).
*/
- if (entryPtr->refCount == 0) {
+ if ((entryPtr->refCount != TCL_INDEX_NONE) && (entryPtr->refCount-- <= 1)) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
@@ -960,8 +972,8 @@ RebuildLiteralTable(
LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
const char *bytes;
- unsigned int oldSize;
- int count, index, length;
+ unsigned int oldSize, index;
+ int count, length;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
@@ -983,7 +995,7 @@ RebuildLiteralTable(
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **)ckalloc(
- tablePtr->numBuckets * sizeof(LiteralEntry *));
+ tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
@@ -1033,7 +1045,7 @@ RebuildLiteralTable(
*
* Side effects:
* Resets the internal representation of the CmdName Tcl_Obj
- * using TclFreeIntRep().
+ * using TclFreeInternalRep().
*
*----------------------------------------------------------------------
*/
@@ -1048,12 +1060,12 @@ TclInvalidateCmdLiteral(
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
+ Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL) {
- if (literalObjPtr->typePtr == &tclCmdNameType) {
- TclFreeIntRep(literalObjPtr);
+ if (TclHasInternalRep(literalObjPtr, &tclCmdNameType)) {
+ TclFreeInternalRep(literalObjPtr);
}
/* Balance the refcount effects of TclCreateLiteral() above */
Tcl_IncrRefCount(literalObjPtr);
@@ -1085,7 +1097,9 @@ TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
- int count[NUM_COUNTERS], overflow, i, j;
+ size_t count[NUM_COUNTERS];
+ int overflow;
+ size_t i, j;
double average, tmp;
LiteralEntry *entryPtr;
char *result, *p;
@@ -1124,7 +1138,7 @@ TclLiteralStats(
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i=0 ; i<NUM_COUNTERS ; i++) {
- sprintf(p, "number of buckets with %d entries: %d\n",
+ sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
}
@@ -1161,17 +1175,17 @@ TclVerifyLocalLiteralTable(
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
char *bytes;
- int i;
- int length, count;
+ size_t i, count;
+ int length;
count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
- if (localPtr->refCount != -1) {
- bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
+ if (localPtr->refCount != TCL_INDEX_NONE) {
+ bytes = TclGetStringFromObj(localPtr->objPtr, &length);
+ Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
@@ -1182,7 +1196,7 @@ TclVerifyLocalLiteralTable(
}
}
if (count != localTablePtr->numEntries) {
- Tcl_Panic("%s: local literal table had %d entries, should be %d",
+ Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyLocalLiteralTable", count,
localTablePtr->numEntries);
}
@@ -1212,16 +1226,16 @@ TclVerifyGlobalLiteralTable(
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
char *bytes;
- int i;
- int length, count;
+ size_t i, count;
+ int length;
count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
- if (globalPtr->refCount < 1) {
- bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
+ if (globalPtr->refCount + 1 < 2) {
+ bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : length), bytes, globalPtr->refCount);
@@ -1233,7 +1247,7 @@ TclVerifyGlobalLiteralTable(
}
}
if (count != globalTablePtr->numEntries) {
- Tcl_Panic("%s: global literal table had %d entries, should be %d",
+ Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyGlobalLiteralTable", count,
globalTablePtr->numEntries);
}
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 08a0bcc..ee1862d 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -4,7 +4,7 @@
* This file provides the generic portion (those that are the same on all
* platforms) of Tcl's dynamic loading facilities.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -12,20 +12,21 @@
#include "tclInt.h"
+
/*
- * The following structure describes a package that has been loaded either
+ * The following structure describes a library that has been loaded either
* dynamically (with the "load" command) or statically (as indicated by a call
- * to TclGetLoadedPackages). All such packages are linked together into a
- * single list for the process. Packages are never unloaded, until the
+ * to Tcl_StaticLibrary). All such libraries are linked together into a
+ * single list for the process. Library are never unloaded, until the
* application exits, when TclFinalizeLoad is called, and these structures are
* freed.
*/
-typedef struct LoadedPackage {
- char *fileName; /* Name of the file from which the package was
- * loaded. An empty string means the package
+typedef struct LoadedLibrary {
+ char *fileName; /* Name of the file from which the library was
+ * loaded. An empty string means the library
* is loaded statically. Malloc-ed. */
- char *packageName; /* Name of package prefix for the package,
+ char *prefix; /* Prefix for the library,
* properly capitalized (first letter UC,
* others LC), as in "Net".
* Malloc-ed. */
@@ -33,68 +34,80 @@ typedef struct LoadedPackage {
* passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
- Tcl_PackageInitProc *initProc;
+ Tcl_LibraryInitProc *initProc;
/* Initialization function to call to
- * incorporate this package into a trusted
+ * incorporate this library into a trusted
* interpreter. */
- Tcl_PackageInitProc *safeInitProc;
+ Tcl_LibraryInitProc *safeInitProc;
/* Initialization function to call to
- * incorporate this package into a safe
+ * incorporate this library into a safe
* interpreter (one that will execute
- * untrusted scripts). NULL means the package
+ * untrusted scripts). NULL means the library
* can't be used in unsafe interpreters. */
- Tcl_PackageUnloadProc *unloadProc;
- /* Finalisation function to unload a package
+ Tcl_LibraryUnloadProc *unloadProc;
+ /* Finalization function to unload a library
* from a trusted interpreter. NULL means that
- * the package cannot be unloaded. */
- Tcl_PackageUnloadProc *safeUnloadProc;
- /* Finalisation function to unload a package
+ * the library cannot be unloaded. */
+ Tcl_LibraryUnloadProc *safeUnloadProc;
+ /* Finalization function to unload a library
* from a safe interpreter. NULL means that
- * the package cannot be unloaded. */
- int interpRefCount; /* How many times the package has been loaded
+ * the library cannot be unloaded. */
+ int interpRefCount; /* How many times the library has been loaded
* in trusted interpreters. */
- int safeInterpRefCount; /* How many times the package has been loaded
+ int safeInterpRefCount; /* How many times the library has been loaded
* in safe interpreters. */
- struct LoadedPackage *nextPtr;
- /* Next in list of all packages loaded into
+ struct LoadedLibrary *nextPtr;
+ /* Next in list of all libraries loaded into
* this application process. NULL means end of
* list. */
-} LoadedPackage;
+} LoadedLibrary;
/*
* TCL_THREADS
- * There is a global list of packages that is anchored at firstPackagePtr.
+ * There is a global list of libraries that is anchored at firstLibraryPtr.
* Access to this list is governed by a mutex.
*/
-static LoadedPackage *firstPackagePtr = NULL;
- /* First in list of all packages loaded into
+static LoadedLibrary *firstLibraryPtr = NULL;
+ /* First in list of all libraries loaded into
* this process. */
-TCL_DECLARE_MUTEX(packageMutex)
+TCL_DECLARE_MUTEX(libraryMutex)
/*
- * The following structure represents a particular package that has been
+ * The following structure represents a particular library that has been
* incorporated into a particular interpreter (by calling its initialization
* function). There is a list of these structures for each interpreter, with
* an AssocData value (key "load") for the interpreter that points to the
- * first package (if any).
+ * first library (if any).
*/
-typedef struct InterpPackage {
- LoadedPackage *pkgPtr; /* Points to detailed information about
- * package. */
- struct InterpPackage *nextPtr;
- /* Next package in this interpreter, or NULL
+typedef struct InterpLibrary {
+ LoadedLibrary *libraryPtr; /* Points to detailed information about
+ * library. */
+ struct InterpLibrary *nextPtr;
+ /* Next library in this interpreter, or NULL
* for end of list. */
-} InterpPackage;
+} InterpLibrary;
/*
* Prototypes for functions that are private to this file:
*/
-static void LoadCleanupProc(ClientData clientData,
- Tcl_Interp *interp);
+static void LoadCleanupProc(ClientData clientData,
+ Tcl_Interp *interp);
+static int IsStatic (LoadedLibrary *libraryPtr);
+static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
+ LoadedLibrary *library, int keepLibrary,
+ const char *fullFileName, int interpExiting);
+
+
+static int
+IsStatic (LoadedLibrary *libraryPtr) {
+ int res;
+ res = (libraryPtr->fileName[0] == '\0');
+ return res;
+}
/*
*----------------------------------------------------------------------
@@ -115,20 +128,20 @@ static void LoadCleanupProc(ClientData clientData,
int
Tcl_LoadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
- LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString prefix, tmp, initName, safeInitName;
+ LoadedLibrary *libraryPtr, *defaultPtr;
+ Tcl_DString pfx, tmp, initName, safeInitName;
Tcl_DString unloadName, safeUnloadName;
- InterpPackage *ipFirstPtr, *ipPtr;
+ InterpLibrary *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
- Tcl_PackageInitProc *initProc;
- const char *p, *fullFileName, *packageName;
+ Tcl_LibraryInitProc *initProc;
+ const char *p, *fullFileName, *prefix;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
unsigned len;
@@ -137,7 +150,7 @@ Tcl_LoadObjCmd(
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
- enum options {
+ enum loadOptionsEnum {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
};
@@ -150,16 +163,16 @@ Tcl_LoadObjCmd(
return TCL_ERROR;
}
++objv; --objc;
- if (LOAD_GLOBAL == (enum options) index) {
+ if (LOAD_GLOBAL == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_GLOBAL;
- } else if (LOAD_LAZY == (enum options) index) {
+ } else if (LOAD_LAZY == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
+ Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
@@ -167,23 +180,23 @@ Tcl_LoadObjCmd(
}
fullFileName = Tcl_GetString(objv[1]);
- Tcl_DStringInit(&prefix);
+ Tcl_DStringInit(&pfx);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
Tcl_DStringInit(&unloadName);
Tcl_DStringInit(&safeUnloadName);
Tcl_DStringInit(&tmp);
- packageName = NULL;
+ prefix = NULL;
if (objc >= 3) {
- packageName = Tcl_GetString(objv[2]);
- if (packageName[0] == '\0') {
- packageName = NULL;
+ prefix = Tcl_GetString(objv[2]);
+ if (prefix[0] == '\0') {
+ prefix = NULL;
}
}
- if ((fullFileName[0] == 0) && (packageName == NULL)) {
+ if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "must specify either file name or package name", -1));
+ "must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -191,7 +204,7 @@ Tcl_LoadObjCmd(
}
/*
- * Figure out which interpreter we're going to load the package into.
+ * Figure out which interpreter we're going to load the library into.
*/
target = interp;
@@ -206,89 +219,89 @@ Tcl_LoadObjCmd(
}
/*
- * Scan through the packages that are currently loaded to see if the
- * package we want is already loaded. We'll use a loaded package if it
+ * Scan through the libraries that are currently loaded to see if the
+ * library we want is already loaded. We'll use a loaded library if it
* meets any of the following conditions:
* - Its name and file match the once we're looking for.
* - Its file matches, and we weren't given a name.
* - Its name matches, the file name was specified as empty, and there is
- * only no statically loaded package with the same name.
+ * only no statically loaded library with the same prefix.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
defaultPtr = NULL;
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
- if (packageName == NULL) {
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
+ if (prefix == NULL) {
namesMatch = 0;
} else {
- TclDStringClear(&prefix);
- Tcl_DStringAppend(&prefix, packageName, -1);
+ TclDStringClear(&pfx);
+ Tcl_DStringAppend(&pfx, prefix, -1);
TclDStringClear(&tmp);
- Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
- Tcl_UtfToLower(Tcl_DStringValue(&prefix));
+ Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pfx));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
- Tcl_DStringValue(&prefix)) == 0) {
+ Tcl_DStringValue(&pfx)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
- TclDStringClear(&prefix);
+ TclDStringClear(&pfx);
- filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
- if (filesMatch && (namesMatch || (packageName == NULL))) {
+ filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
+ if (filesMatch && (namesMatch || (prefix == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
- defaultPtr = pkgPtr;
+ defaultPtr = libraryPtr;
}
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
/*
- * Can't have two different packages loaded from the same file.
+ * Can't have two different libraries loaded from the same file.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" is already loaded for package \"%s\"",
- fullFileName, pkgPtr->packageName));
+ "file \"%s\" is already loaded for prefix \"%s\"",
+ fullFileName, libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"SPLITPERSONALITY", NULL);
code = TCL_ERROR;
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
goto done;
}
}
- Tcl_MutexUnlock(&packageMutex);
- if (pkgPtr == NULL) {
- pkgPtr = defaultPtr;
+ Tcl_MutexUnlock(&libraryMutex);
+ if (libraryPtr == NULL) {
+ libraryPtr = defaultPtr;
}
/*
- * Scan through the list of packages already loaded in the target
- * interpreter. If the package we want is already loaded there, then
+ * Scan through the list of libraries already loaded in the target
+ * interpreter. If the library we want is already loaded there, then
* there's nothing for us to do.
*/
- if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ if (libraryPtr != NULL) {
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
code = TCL_OK;
goto done;
}
}
}
- if (pkgPtr == NULL) {
+ if (libraryPtr == NULL) {
/*
* The desired file isn't currently loaded, so load it. It's an error
- * if the desired package is a static one.
+ * if the desired library is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "package \"%s\" isn't loaded statically", packageName));
+ "no library with prefix \"%s\" is loaded statically", prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
NULL);
code = TCL_ERROR;
@@ -296,136 +309,139 @@ Tcl_LoadObjCmd(
}
/*
- * Figure out the module name if it wasn't provided explicitly.
+ * Figure out the prefix if it wasn't provided explicitly.
*/
- if (packageName != NULL) {
- Tcl_DStringAppend(&prefix, packageName, -1);
+ if (prefix != NULL) {
+ Tcl_DStringAppend(&pfx, prefix, -1);
} else {
- int retc;
+ Tcl_Obj *splitPtr, *pkgGuessPtr;
+ int pElements;
+ const char *pkgGuess;
/*
* Threading note - this call used to be protected by a mutex.
*/
- retc = TclGuessPackageName(fullFileName, &prefix);
- if (!retc) {
- Tcl_Obj *splitPtr, *pkgGuessPtr;
- int pElements;
- const char *pkgGuess;
-
- /*
- * The platform-specific code couldn't figure out the module
- * name. Make a guess by taking the last element of the file
- * name, stripping off any leading "lib", and then using all
- * of the alphabetic and underline characters that follow
- * that.
- */
+ /*
+ * The platform-specific code couldn't figure out the prefix.
+ * Make a guess by taking the last element of the file
+ * name, stripping off any leading "lib" and/or "tcl", and
+ * then using all of the alphabetic and underline characters
+ * that follow that.
+ */
- splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
- Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
- pkgGuess = Tcl_GetString(pkgGuessPtr);
- if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
- && (pkgGuess[2] == 'b')) {
- pkgGuess += 3;
- }
+ splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
+ Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
+ pkgGuess = Tcl_GetString(pkgGuessPtr);
+ if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
+ && (pkgGuess[2] == 'b')) {
+ pkgGuess += 3;
+ }
#ifdef __CYGWIN__
- if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
- && (pkgGuess[2] == 'g')) {
- pkgGuess += 3;
- }
+ else if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
+ && (pkgGuess[2] == 'g')) {
+ pkgGuess += 3;
+ }
#endif /* __CYGWIN__ */
- for (p = pkgGuess; *p != 0; p += offset) {
- offset = TclUtfToUniChar(p, &ch);
- if ((ch > 0x100)
- || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
- || (UCHAR(ch) == '_'))) {
- break;
- }
- }
- if (p == pkgGuess) {
- Tcl_DecrRefCount(splitPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't figure out package name for %s",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
- "WHATPACKAGE", NULL);
- code = TCL_ERROR;
- goto done;
+ if (((pkgGuess[0] == 't')
+#ifdef MAC_OSX_TCL
+ || (pkgGuess[0] == 'T')
+#endif
+ ) && (pkgGuess[1] == 'c')
+ && (pkgGuess[2] == 'l')) {
+ pkgGuess += 3;
+ }
+ for (p = pkgGuess; *p != 0; p += offset) {
+ offset = TclUtfToUniChar(p, &ch);
+ if ((ch > 0x100)
+ || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
+ || (UCHAR(ch) == '_'))) {
+ break;
}
- Tcl_DStringAppend(&prefix, pkgGuess, p - pkgGuess);
+ }
+ if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't figure out prefix for %s",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "WHATLIBRARY", NULL);
+ code = TCL_ERROR;
+ goto done;
}
+ Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess);
+ Tcl_DecrRefCount(splitPtr);
}
/*
- * Fix the capitalization in the package name so that the first
+ * Fix the capitalization in the prefix so that the first
* character is in caps (or title case) but the others are all
* lower-case.
*/
- Tcl_DStringSetLength(&prefix,
- Tcl_UtfToTitle(Tcl_DStringValue(&prefix)));
+ Tcl_DStringSetLength(&pfx,
+ Tcl_UtfToTitle(Tcl_DStringValue(&pfx)));
/*
* Compute the names of the two initialization functions, based on the
- * package name.
+ * prefix.
*/
- TclDStringAppendDString(&initName, &prefix);
+ TclDStringAppendDString(&initName, &pfx);
TclDStringAppendLiteral(&initName, "_Init");
- TclDStringAppendDString(&safeInitName, &prefix);
+ TclDStringAppendDString(&safeInitName, &pfx);
TclDStringAppendLiteral(&safeInitName, "_SafeInit");
- TclDStringAppendDString(&unloadName, &prefix);
+ TclDStringAppendDString(&unloadName, &pfx);
TclDStringAppendLiteral(&unloadName, "_Unload");
- TclDStringAppendDString(&safeUnloadName, &prefix);
+ TclDStringAppendDString(&safeUnloadName, &pfx);
TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload");
/*
- * Call platform-specific code to load the package and find the two
+ * Call platform-specific code to load the library and find the two
* initialization functions.
*/
symbols[0] = Tcl_DStringValue(&initName);
symbols[1] = NULL;
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc,
&loadHandle);
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
if (code != TCL_OK) {
goto done;
}
/*
- * Create a new record to describe this package.
+ * Create a new record to describe this library.
*/
- pkgPtr = ckalloc(sizeof(LoadedPackage));
+ libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary));
len = strlen(fullFileName) + 1;
- pkgPtr->fileName = ckalloc(len);
- memcpy(pkgPtr->fileName, fullFileName, len);
- len = (unsigned) Tcl_DStringLength(&prefix) + 1;
- pkgPtr->packageName = ckalloc(len);
- memcpy(pkgPtr->packageName, Tcl_DStringValue(&prefix), len);
- pkgPtr->loadHandle = loadHandle;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = (Tcl_PackageInitProc *)
+ libraryPtr->fileName = (char *)ckalloc(len);
+ memcpy(libraryPtr->fileName, fullFileName, len);
+ len = Tcl_DStringLength(&pfx) + 1;
+ libraryPtr->prefix = (char *)ckalloc(len);
+ memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len);
+ libraryPtr->loadHandle = loadHandle;
+ libraryPtr->initProc = initProc;
+ libraryPtr->safeInitProc = (Tcl_LibraryInitProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&safeInitName));
- pkgPtr->unloadProc = (Tcl_PackageUnloadProc *)
+ libraryPtr->unloadProc = (Tcl_LibraryUnloadProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&unloadName));
- pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *)
+ libraryPtr->safeUnloadProc = (Tcl_LibraryUnloadProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&safeUnloadName));
- pkgPtr->interpRefCount = 0;
- pkgPtr->safeInterpRefCount = 0;
+ libraryPtr->interpRefCount = 0;
+ libraryPtr->safeInterpRefCount = 0;
- Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
+ libraryPtr->nextPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr;
+ Tcl_MutexUnlock(&libraryMutex);
/*
* The Tcl_FindSymbol calls may have left a spurious error message in
@@ -436,32 +452,32 @@ Tcl_LoadObjCmd(
}
/*
- * Invoke the package's initialization function (either the normal one or
+ * Invoke the library's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
- if (pkgPtr->safeInitProc == NULL) {
+ if (libraryPtr->safeInitProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't use package in a safe interpreter: no"
- " %s_SafeInit procedure", pkgPtr->packageName));
+ "can't use library in a safe interpreter: no"
+ " %s_SafeInit procedure", libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
NULL);
code = TCL_ERROR;
goto done;
}
- code = pkgPtr->safeInitProc(target);
+ code = libraryPtr->safeInitProc(target);
} else {
- if (pkgPtr->initProc == NULL) {
+ if (libraryPtr->initProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't attach package to interpreter: no %s_Init procedure",
- pkgPtr->packageName));
+ "can't attach library to interpreter: no %s_Init procedure",
+ libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
NULL);
code = TCL_ERROR;
goto done;
}
- code = pkgPtr->initProc(target);
+ code = libraryPtr->initProc(target);
}
/*
@@ -470,38 +486,51 @@ Tcl_LoadObjCmd(
*/
if (code != TCL_OK) {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+ Interp *iPtr = (Interp *) target;
+ if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) {
+ /*
+ * A call to Tcl_InitStubs() determined the caller extension and
+ * this interp are incompatible in their stubs mechanisms, and
+ * recorded the error in the oldest legacy place we have to do so.
+ */
+ Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1));
+ iPtr->result = &tclEmptyString;
+ iPtr->freeProc = NULL;
+ }
+#endif /* defined(TCL_NO_DEPRECATED) */
Tcl_TransferResult(target, code, interp);
goto done;
}
/*
- * Record the fact that the package has been loaded in the target
+ * Record the fact that the library has been loaded in the target
* interpreter.
*
* Update the proper reference count.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
if (Tcl_IsSafe(target)) {
- pkgPtr->safeInterpRefCount++;
+ libraryPtr->safeInterpRefCount++;
} else {
- pkgPtr->interpRefCount++;
+ libraryPtr->interpRefCount++;
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
/*
- * Refetch ipFirstPtr: loading the package may have introduced additional
- * static packages at the head of the linked list!
+ * Refetch ipFirstPtr: loading the library may have introduced additional
+ * static libraries at the head of the linked list!
*/
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ckalloc(sizeof(InterpPackage));
- ipPtr->pkgPtr = pkgPtr;
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary));
+ ipPtr->libraryPtr = libraryPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
done:
- Tcl_DStringFree(&prefix);
+ Tcl_DStringFree(&pfx);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
Tcl_DStringFree(&unloadName);
@@ -515,7 +544,7 @@ Tcl_LoadObjCmd(
*
* Tcl_UnloadObjCmd --
*
- * This function is invoked to process the "unload" Tcl command. See the
+ * Implements the the "unload" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
@@ -529,24 +558,22 @@ Tcl_LoadObjCmd(
int
Tcl_UnloadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target; /* Which interpreter to unload from. */
- LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString prefix, tmp;
- Tcl_PackageUnloadProc *unloadProc;
- InterpPackage *ipFirstPtr, *ipPtr;
+ LoadedLibrary *libraryPtr;
+ Tcl_DString pfx, tmp;
+ InterpLibrary *ipFirstPtr, *ipPtr;
int i, index, code, complain = 1, keepLibrary = 0;
- int trustedRefCount = -1, safeRefCount = -1;
const char *fullFileName = "";
- const char *packageName;
+ const char *prefix;
static const char *const options[] = {
"-nocomplain", "-keeplibrary", "--", NULL
};
- enum options {
+ enum unloadOptionsEnum {
UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
};
@@ -571,7 +598,7 @@ Tcl_UnloadObjCmd(
break;
}
}
- switch (index) {
+ switch ((enum unloadOptionsEnum)index) {
case UNLOAD_NOCOMPLAIN: /* -nocomplain */
complain = 0;
break;
@@ -586,7 +613,7 @@ Tcl_UnloadObjCmd(
endOfForLoop:
if ((objc-i < 1) || (objc-i > 3)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?-switch ...? fileName ?packageName? ?interp?");
+ "?-switch ...? fileName ?prefix? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
@@ -594,19 +621,19 @@ Tcl_UnloadObjCmd(
}
fullFileName = Tcl_GetString(objv[i]);
- Tcl_DStringInit(&prefix);
+ Tcl_DStringInit(&pfx);
Tcl_DStringInit(&tmp);
- packageName = NULL;
+ prefix = NULL;
if (objc - i >= 2) {
- packageName = Tcl_GetString(objv[i+1]);
- if (packageName[0] == '\0') {
- packageName = NULL;
+ prefix = Tcl_GetString(objv[i+1]);
+ if (prefix[0] == '\0') {
+ prefix = NULL;
}
}
- if ((fullFileName[0] == 0) && (packageName == NULL)) {
+ if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "must specify either file name or package name", -1));
+ "must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -614,7 +641,7 @@ Tcl_UnloadObjCmd(
}
/*
- * Figure out which interpreter we're going to load the package into.
+ * Figure out which interpreter we're going to load the library into.
*/
target = interp;
@@ -628,65 +655,61 @@ Tcl_UnloadObjCmd(
}
/*
- * Scan through the packages that are currently loaded to see if the
- * package we want is already loaded. We'll use a loaded package if it
+ * Scan through the libraries that are currently loaded to see if the
+ * library we want is already loaded. We'll use a loaded library if it
* meets any of the following conditions:
- * - Its name and file match the once we're looking for.
- * - Its file matches, and we weren't given a name.
- * - Its name matches, the file name was specified as empty, and there is
- * only no statically loaded package with the same name.
+ * - Its prefix and file match the once we're looking for.
+ * - Its file matches, and we weren't given a prefix.
+ * - Its prefix matches, the file name was specified as empty, and there is
+ * no statically loaded library with the same prefix.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
- defaultPtr = NULL;
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
int namesMatch, filesMatch;
- if (packageName == NULL) {
+ if (prefix == NULL) {
namesMatch = 0;
} else {
- TclDStringClear(&prefix);
- Tcl_DStringAppend(&prefix, packageName, -1);
+ TclDStringClear(&pfx);
+ Tcl_DStringAppend(&pfx, prefix, -1);
TclDStringClear(&tmp);
- Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
- Tcl_UtfToLower(Tcl_DStringValue(&prefix));
+ Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pfx));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
- Tcl_DStringValue(&prefix)) == 0) {
+ Tcl_DStringValue(&pfx)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
- TclDStringClear(&prefix);
+ TclDStringClear(&pfx);
- filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
- if (filesMatch && (namesMatch || (packageName == NULL))) {
+ filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
+ if (filesMatch && (namesMatch || (prefix == NULL))) {
break;
}
- if (namesMatch && (fullFileName[0] == 0)) {
- defaultPtr = pkgPtr;
- }
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
break;
}
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
if (fullFileName[0] == 0) {
/*
- * It's an error to try unload a static package.
+ * It's an error to try unload a static library.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "package \"%s\" is loaded statically and cannot be unloaded",
- packageName));
+ "library with prefix \"%s\" is loaded statically and cannot be unloaded",
+ prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
NULL);
code = TCL_ERROR;
goto done;
}
- if (pkgPtr == NULL) {
+ if (libraryPtr == NULL) {
/*
* The DLL pointed by the provided filename has never been loaded.
*/
@@ -700,16 +723,16 @@ Tcl_UnloadObjCmd(
}
/*
- * Scan through the list of packages already loaded in the target
- * interpreter. If the package we want is already loaded there, then we
+ * Scan through the list of libraries already loaded in the target
+ * interpreter. If the library we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
- if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ if (libraryPtr != NULL) {
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
code = TCL_OK;
break;
}
@@ -717,7 +740,7 @@ Tcl_UnloadObjCmd(
}
if (code != TCL_OK) {
/*
- * The package has not been loaded in this interpreter.
+ * The library has not been loaded in this interpreter.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -729,38 +752,89 @@ Tcl_UnloadObjCmd(
goto done;
}
+ code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);
+
+ done:
+ Tcl_DStringFree(&pfx);
+ Tcl_DStringFree(&tmp);
+ if (!complain && (code != TCL_OK)) {
+ code = TCL_OK;
+ Tcl_ResetResult(interp);
+ }
+ return code;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnloadLibrary --
+ *
+ * Unloads a library from an interpreter, and also from the process if it
+ * is unloadable, i.e. if it provides an "unload" function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+UnloadLibrary(
+ Tcl_Interp *interp,
+ Tcl_Interp *target,
+ LoadedLibrary *libraryPtr,
+ int keepLibrary,
+ const char *fullFileName,
+ int interpExiting
+)
+{
+ int code;
+ InterpLibrary *ipFirstPtr, *ipPtr;
+ LoadedLibrary *iterLibraryPtr;
+ int trustedRefCount = -1, safeRefCount = -1;
+ Tcl_LibraryUnloadProc *unloadProc = NULL;
+
/*
* Ensure that the DLL can be unloaded. If it is a trusted interpreter,
- * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If
- * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL.
+ * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If
+ * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL.
*/
if (Tcl_IsSafe(target)) {
- if (pkgPtr->safeUnloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a safe interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (libraryPtr->safeUnloadProc == NULL) {
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a safe interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
- unloadProc = pkgPtr->safeUnloadProc;
+ unloadProc = libraryPtr->safeUnloadProc;
} else {
- if (pkgPtr->unloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a trusted interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (libraryPtr->unloadProc == NULL) {
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a trusted interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
- unloadProc = pkgPtr->unloadProc;
+ unloadProc = libraryPtr->unloadProc;
}
+
+
/*
- * We are ready to unload the package. First, evaluate the unload
+ * We are ready to unload the library. First, evaluate the unload
* function. If this fails, we cannot proceed with unload. Also, we must
* specify the proper flag to pass to the unload callback.
* TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
@@ -769,63 +843,96 @@ Tcl_UnloadObjCmd(
* after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
*/
- code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
- if (!keepLibrary) {
- Tcl_MutexLock(&packageMutex);
- trustedRefCount = pkgPtr->interpRefCount;
- safeRefCount = pkgPtr->safeInterpRefCount;
- Tcl_MutexUnlock(&packageMutex);
-
- if (Tcl_IsSafe(target)) {
- safeRefCount--;
- } else {
- trustedRefCount--;
- }
+ if (unloadProc == NULL) {
+ code = TCL_OK;
+ } else {
+ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
+ if (!keepLibrary) {
+ Tcl_MutexLock(&libraryMutex);
+ trustedRefCount = libraryPtr->interpRefCount;
+ safeRefCount = libraryPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&libraryMutex);
+
+ if (Tcl_IsSafe(target)) {
+ safeRefCount--;
+ } else {
+ trustedRefCount--;
+ }
- if (safeRefCount <= 0 && trustedRefCount <= 0) {
- code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ if (safeRefCount <= 0 && trustedRefCount <= 0) {
+ code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ }
}
+ code = unloadProc(target, code);
}
- code = unloadProc(target, code);
+
+
if (code != TCL_OK) {
Tcl_TransferResult(target, code, interp);
goto done;
}
+
+ /*
+ * Remove this library from the interpreter's library cache.
+ */
+
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = ipFirstPtr;
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipFirstPtr = ipFirstPtr->nextPtr;
+ } else {
+ InterpLibrary *ipPrevPtr;
+
+ for (ipPrevPtr = ipPtr; ipPtr != NULL;
+ ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipPrevPtr->nextPtr = ipPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ ckfree(ipPtr);
+ Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);
+
+
+ if (IsStatic(libraryPtr)) {
+ goto done;
+ }
+
/*
- * The unload function executed fine. Examine the reference count to see
- * if we unload the DLL.
+ * The unload function was called succesfully.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
if (Tcl_IsSafe(target)) {
- pkgPtr->safeInterpRefCount--;
+ libraryPtr->safeInterpRefCount--;
/*
* Do not let counter get negative.
*/
- if (pkgPtr->safeInterpRefCount < 0) {
- pkgPtr->safeInterpRefCount = 0;
+ if (libraryPtr->safeInterpRefCount < 0) {
+ libraryPtr->safeInterpRefCount = 0;
}
} else {
- pkgPtr->interpRefCount--;
+ libraryPtr->interpRefCount--;
/*
* Do not let counter get negative.
*/
- if (pkgPtr->interpRefCount < 0) {
- pkgPtr->interpRefCount = 0;
+ if (libraryPtr->interpRefCount < 0) {
+ libraryPtr->interpRefCount = 0;
}
}
- trustedRefCount = pkgPtr->interpRefCount;
- safeRefCount = pkgPtr->safeInterpRefCount;
- Tcl_MutexUnlock(&packageMutex);
+ trustedRefCount = libraryPtr->interpRefCount;
+ safeRefCount = libraryPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&libraryMutex);
code = TCL_OK;
- if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
- && !keepLibrary) {
+ if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0
+ && (unloadProc != NULL) && !keepLibrary) {
/*
* Unload the shared library from the application memory...
*/
@@ -838,52 +945,30 @@ Tcl_UnloadObjCmd(
* it's been unloaded.
*/
- if (pkgPtr->fileName[0] != '\0') {
- Tcl_MutexLock(&packageMutex);
- if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {
+ if (!IsStatic(libraryPtr)) {
+ Tcl_MutexLock(&libraryMutex);
+ if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) {
/*
* Remove this library from the loaded library cache.
*/
- defaultPtr = pkgPtr;
- if (defaultPtr == firstPackagePtr) {
- firstPackagePtr = pkgPtr->nextPtr;
+ iterLibraryPtr = libraryPtr;
+ if (iterLibraryPtr == firstLibraryPtr) {
+ firstLibraryPtr = libraryPtr->nextPtr;
} else {
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
- pkgPtr = pkgPtr->nextPtr) {
- if (pkgPtr->nextPtr == defaultPtr) {
- pkgPtr->nextPtr = defaultPtr->nextPtr;
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
+ libraryPtr = libraryPtr->nextPtr) {
+ if (libraryPtr->nextPtr == iterLibraryPtr) {
+ libraryPtr->nextPtr = iterLibraryPtr->nextPtr;
break;
}
}
}
- /*
- * Remove this library from the interpreter's library cache.
- */
-
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ipFirstPtr;
- if (ipPtr->pkgPtr == defaultPtr) {
- ipFirstPtr = ipFirstPtr->nextPtr;
- } else {
- InterpPackage *ipPrevPtr;
-
- for (ipPrevPtr = ipPtr; ipPtr != NULL;
- ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == defaultPtr) {
- ipPrevPtr->nextPtr = ipPtr->nextPtr;
- break;
- }
- }
- }
- Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
- ipFirstPtr);
- ckfree(defaultPtr->fileName);
- ckfree(defaultPtr->packageName);
- ckfree(defaultPtr);
- ckfree(ipPtr);
- Tcl_MutexUnlock(&packageMutex);
+ ckfree(iterLibraryPtr->fileName);
+ ckfree(iterLibraryPtr->prefix);
+ ckfree(iterLibraryPtr);
+ Tcl_MutexUnlock(&libraryMutex);
} else {
code = TCL_ERROR;
}
@@ -899,111 +984,107 @@ Tcl_UnloadObjCmd(
}
done:
- Tcl_DStringFree(&prefix);
- Tcl_DStringFree(&tmp);
- if (!complain && (code != TCL_OK)) {
- code = TCL_OK;
- Tcl_ResetResult(interp);
- }
return code;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_StaticPackage --
+ * Tcl_StaticLibrary --
*
- * This function is invoked to indicate that a particular package has
+ * This function is invoked to indicate that a particular library has
* been linked statically with an application.
*
* Results:
* None.
*
* Side effects:
- * Once this function completes, the package becomes loadable via the
+ * Once this function completes, the library becomes loadable via the
* "load" command with an empty file name.
*
*----------------------------------------------------------------------
*/
void
-Tcl_StaticPackage(
- Tcl_Interp *interp, /* If not NULL, it means that the package has
+Tcl_StaticLibrary(
+ Tcl_Interp *interp, /* If not NULL, it means that the library has
* already been loaded into the given
* interpreter by calling the appropriate init
* proc. */
const char *prefix, /* Prefix (must be properly
* capitalized: first letter upper case,
* others lower case). */
- Tcl_PackageInitProc *initProc,
+ Tcl_LibraryInitProc *initProc,
/* Function to call to incorporate this
- * package into a trusted interpreter. */
- Tcl_PackageInitProc *safeInitProc)
+ * library into a trusted interpreter. */
+ Tcl_LibraryInitProc *safeInitProc)
/* Function to call to incorporate this
- * package into a safe interpreter (one that
+ * library into a safe interpreter (one that
* will execute untrusted scripts). NULL means
- * the package can't be used in safe
+ * the library can't be used in safe
* interpreters. */
{
- LoadedPackage *pkgPtr;
- InterpPackage *ipPtr, *ipFirstPtr;
+ LoadedLibrary *libraryPtr;
+ InterpLibrary *ipPtr, *ipFirstPtr;
/*
- * Check to see if someone else has already reported this package as
+ * Check to see if someone else has already reported this library as
* statically loaded in the process.
*/
- Tcl_MutexLock(&packageMutex);
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
- if ((pkgPtr->initProc == initProc)
- && (pkgPtr->safeInitProc == safeInitProc)
- && (strcmp(pkgPtr->packageName, prefix) == 0)) {
+ Tcl_MutexLock(&libraryMutex);
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
+ if ((libraryPtr->initProc == initProc)
+ && (libraryPtr->safeInitProc == safeInitProc)
+ && (strcmp(libraryPtr->prefix, prefix) == 0)) {
break;
}
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
/*
- * If the package is not yet recorded as being loaded statically, add it
+ * If the library is not yet recorded as being loaded statically, add it
* to the list now.
*/
- if (pkgPtr == NULL) {
- pkgPtr = ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = ckalloc(1);
- pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = ckalloc(strlen(prefix) + 1);
- strcpy(pkgPtr->packageName, prefix);
- pkgPtr->loadHandle = NULL;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
- Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
- Tcl_MutexUnlock(&packageMutex);
+ if (libraryPtr == NULL) {
+ libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary));
+ libraryPtr->fileName = (char *)ckalloc(1);
+ libraryPtr->fileName[0] = 0;
+ libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1);
+ strcpy(libraryPtr->prefix, prefix);
+ libraryPtr->loadHandle = NULL;
+ libraryPtr->initProc = initProc;
+ libraryPtr->safeInitProc = safeInitProc;
+ libraryPtr->unloadProc = NULL;
+ libraryPtr->safeUnloadProc = NULL;
+ Tcl_MutexLock(&libraryMutex);
+ libraryPtr->nextPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr;
+ Tcl_MutexUnlock(&libraryMutex);
}
if (interp != NULL) {
/*
- * If we're loading the package into an interpreter, determine whether
+ * If we're loading the library into an interpreter, determine whether
* it's already loaded.
*/
- ipFirstPtr = Tcl_GetAssocData(interp, "tclLoad", NULL);
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
return;
}
}
/*
- * Package isn't loade in the current interp yet. Mark it as now being
+ * Library isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
- ipPtr = ckalloc(sizeof(InterpPackage));
- ipPtr->pkgPtr = pkgPtr;
+ ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary));
+ ipPtr->libraryPtr = libraryPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
@@ -1012,17 +1093,17 @@ Tcl_StaticPackage(
/*
*----------------------------------------------------------------------
*
- * TclGetLoadedPackages --
+ * TclGetLoadedLibraries --
*
* This function returns information about all of the files that are
- * loaded (either in a particular intepreter, or for all interpreters).
+ * loaded (either in a particular interpreter, or for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If successful, a
* list of lists is placed in the interp's result. Each sublist
* corresponds to one loaded file; its first element is the name of the
* file (or an empty string for something that's statically loaded) and
- * the second element is the name of the package in that file.
+ * the second element is the prefix of the library in that file.
*
* Side effects:
* None.
@@ -1031,53 +1112,74 @@ Tcl_StaticPackage(
*/
int
-TclGetLoadedPackages(
+TclGetLoadedLibraries(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
- const 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. */
+ const char *prefix) /* Prefix or NULL. If NULL, return info
+ * for all prefixes.
+ */
{
Tcl_Interp *target;
- LoadedPackage *pkgPtr;
- InterpPackage *ipPtr;
+ LoadedLibrary *libraryPtr;
+ InterpLibrary *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
- /*
- * Return information about all of the available packages.
- */
-
TclNewObj(resultObj);
- Tcl_MutexLock(&packageMutex);
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
- pkgPtr = pkgPtr->nextPtr) {
- pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
- pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+ Tcl_MutexLock(&libraryMutex);
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
+ libraryPtr = libraryPtr->nextPtr) {
+ pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewListObj(2, pkgDesc));
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
- /*
- * Return information about only the packages that are loaded in a given
- * interpreter.
- */
-
target = Tcl_GetChild(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
- ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+
+ /*
+ * Return information about all of the available libraries.
+ */
+ if (prefix) {
+ resultObj = NULL;
+
+ for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ libraryPtr = ipPtr->libraryPtr;
+
+ if (!strcmp(prefix, libraryPtr->prefix)) {
+ resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ break;
+ }
+ }
+
+ if (resultObj) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Return information about only the libraries that are loaded in a given
+ * interpreter.
+ */
+
TclNewObj(resultObj);
for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- pkgPtr = ipPtr->pkgPtr;
- pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
- pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+ libraryPtr = ipPtr->libraryPtr;
+ pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
}
Tcl_SetObjResult(interp, resultObj);
@@ -1089,7 +1191,7 @@ TclGetLoadedPackages(
*
* LoadCleanupProc --
*
- * This function is called to delete all of the InterpPackage structures
+ * This function is called to delete all of the InterpLibrary structures
* for an interpreter when the interpreter is deleted. It gets invoked
* via the Tcl AssocData mechanism.
*
@@ -1097,24 +1199,27 @@ TclGetLoadedPackages(
* None.
*
* Side effects:
- * Storage for all of the InterpPackage functions for interp get deleted.
+ * Storage for all of the InterpLibrary functions for interp get deleted.
*
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
- ClientData clientData, /* Pointer to first InterpPackage structure
+ TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure
* for interp. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
+ Tcl_Interp *interp)
{
- InterpPackage *ipPtr, *nextPtr;
+ InterpLibrary *ipPtr;
+ LoadedLibrary *libraryPtr;
- ipPtr = clientData;
- while (ipPtr != NULL) {
- nextPtr = ipPtr->nextPtr;
- ckfree(ipPtr);
- ipPtr = nextPtr;
+ while (1) {
+ ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
+ if (ipPtr == NULL) {
+ break;
+ }
+ libraryPtr = ipPtr->libraryPtr;
+ UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1);
}
}
@@ -1124,7 +1229,7 @@ LoadCleanupProc(
* TclFinalizeLoad --
*
* This function is invoked just before the application exits. It frees
- * all of the LoadedPackage structures.
+ * all of the LoadedLibrary structures.
*
* Results:
* None.
@@ -1138,18 +1243,18 @@ LoadCleanupProc(
void
TclFinalizeLoad(void)
{
- LoadedPackage *pkgPtr;
+ LoadedLibrary *libraryPtr;
/*
* No synchronization here because there should just be one thread alive
- * at this point. Logically, packageMutex should be grabbed at this point,
+ * at this point. Logically, libraryMutex should be grabbed at this point,
* but the Mutexes get finalized before the call to this routine. The only
* subsystem left alive at this point is the memory allocator.
*/
- while (firstPackagePtr != NULL) {
- pkgPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr->nextPtr;
+ while (firstLibraryPtr != NULL) {
+ libraryPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr->nextPtr;
#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32)
/*
@@ -1159,14 +1264,14 @@ TclFinalizeLoad(void)
* it has been unloaded.
*/
- if (pkgPtr->fileName[0] != '\0') {
- Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
+ if (!IsStatic(libraryPtr)) {
+ Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle);
}
#endif
- ckfree(pkgPtr->fileName);
- ckfree(pkgPtr->packageName);
- ckfree(pkgPtr);
+ ckfree(libraryPtr->fileName);
+ ckfree(libraryPtr->prefix);
+ ckfree(libraryPtr);
}
}
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index 6af5c4f..f60f843 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -4,7 +4,7 @@
* 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.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -54,36 +54,6 @@ TclpDlopen(
}
/*
- *----------------------------------------------------------------------
- *
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package name,
- * this procedure is invoked to try to figure it out.
- *
- * Results:
- * Always returns 0 to indicate that we couldn't figure out a package
- * name; generic code will then try to guess the package from the file
- * name. A return value of 1 would have meant that we figured out the
- * package name and put it in bufPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclGuessPackageName(
- 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. */
-{
- return 0;
-}
-
-/*
* These functions are fallbacks if we somehow determine that the platform can
* do loading from memory but the user wishes to disable it. They just report
* (gracefully) that they fail.
@@ -93,8 +63,8 @@ TclGuessPackageName(
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
- Tcl_Interp *interp, /* Dummy: unused by this implementation */
- int size) /* Dummy: unused by this implementation */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int))
{
return NULL;
}
@@ -102,14 +72,12 @@ TclpLoadMemoryGetBuffer(
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
- void *buffer, /* Dummy: unused by this implementation */
- int size, /* Dummy: unused by this implementation */
- int codeSize, /* Dummy: unused by this implementation */
- Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */
- Tcl_FSUnloadFileProc **unloadProcPtr,
- /* Dummy: unused by this implementation */
- int flags)
- /* Dummy: unused by this implementation */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int),
+ TCL_UNUSED(int),
+ TCL_UNUSED(Tcl_LoadHandle *),
+ TCL_UNUSED(Tcl_FSUnloadFileProc **),
+ TCL_UNUSED(int))
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 3f72838..628deaa 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -8,9 +8,9 @@
* 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.
- * Copyright (c) 2000 Ajuba Solutions.
+ * Copyright © 1988-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -50,11 +50,12 @@ NewNativeObj(
Tcl_DString ds;
#ifdef UNICODE
- Tcl_WinTCharToUtf(string, -1, &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString(string, -1, &ds);
#else
- Tcl_ExternalToUtfDString(NULL, (char *) string, -1, &ds);
+ Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds);
#endif
- return TclDStringToObj(&ds);
+ return Tcl_DStringToObj(&ds);
}
/*
@@ -63,11 +64,6 @@ NewNativeObj(
* source directory to make their own modified versions).
*/
-#if defined _MSC_VER && _MSC_VER < 1900
-/* isatty is always defined on MSVC 14.0, but not necessarily as CRTIMPORT. */
-extern CRTIMPORT int isatty(int fd);
-#endif
-
/*
* The thread-local variables for this file's functions.
*/
@@ -266,7 +262,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
- * Tcl_Main, Tcl_MainEx --
+ * Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -292,6 +288,7 @@ Tcl_MainEx(
* but before starting to execute commands. */
Tcl_Interp *interp)
{
+ int i=0; /* argv[i] index */
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
@@ -300,7 +297,13 @@ Tcl_MainEx(
InteractiveState is;
TclpSetInitialEncodings();
- TclpFindExecutable((const char *)argv[0]);
+ if (0 < argc) {
+ --argc; /* "consume" argv[0] */
+ ++i;
+ }
+ TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL
+ * w/ (eg) an empty argv
+ * supplied to execve() */
Tcl_InitMemory(interp);
@@ -322,18 +325,19 @@ Tcl_MainEx(
* FILENAME
*/
- if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
+ /* mind argc is being adjusted as we proceed */
+ if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
- argv += 3;
- } else if ((argc > 1) && ('-' != argv[1][0])) {
+ i += 3;
+ } else if ((argc >= 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
- argv++;
+ i++;
}
}
@@ -344,14 +348,12 @@ Tcl_MainEx(
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
- argc--;
- argv++;
- Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
- Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++));
+ Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
@@ -361,7 +363,7 @@ Tcl_MainEx(
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
- Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
@@ -445,7 +447,7 @@ Tcl_MainEx(
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
- Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
+ Tcl_LinkVar(interp, "tcl_interactive", &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
@@ -617,21 +619,6 @@ Tcl_MainEx(
Tcl_Exit(exitCode);
}
-
-#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
-#undef Tcl_Main
-extern DLLEXPORT void
-Tcl_Main(
- int argc, /* Number of arguments. */
- char **argv, /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc)
- /* Application-specific initialization
- * function to call after most initialization
- * but before starting to execute commands. */
-{
- Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
-}
-#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#if !defined(_WIN32) || defined(UNICODE)
@@ -748,7 +735,7 @@ TclFullFinalizationRequested(void)
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
- int mask) /* Not used. */
+ TCL_UNUSED(int) /*mask*/)
{
int code;
int length;
@@ -756,7 +743,6 @@ StdinProc(
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
- (void)mask;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 7290bd1..5a2979e 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -7,11 +7,11 @@
* children of the global namespace. These other namespaces contain
* special-purpose commands and variables for packages.
*
- * Copyright (c) 1993-1997 Lucent Technologies.
- * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2002-2005 Donal K. Fellows.
- * Copyright (c) 2006 Neil Madden.
+ * Copyright © 1993-1997 Lucent Technologies.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2002-2005 Donal K. Fellows.
+ * Copyright © 2006 Neil Madden.
* Contributions from Don Porter, NIST, 2007. (not subject to US copyright)
*
* Originally implemented by
@@ -25,6 +25,7 @@
#include "tclInt.h"
#include "tclCompile.h" /* for TclLogCommandInfo visibility */
+#include <assert.h>
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -32,7 +33,7 @@
*/
typedef struct {
- long numNsCreated; /* Count of the number of namespaces created
+ unsigned long numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
@@ -59,7 +60,7 @@ typedef struct ResolvedNsName {
* 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
+ size_t refCount; /* Reference count: 1 for each nsName object
* that has a pointer to this ResolvedNsName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -91,7 +92,6 @@ static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
static int InvokeImportedNRCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static Tcl_ObjCmdProc InvokeImportedCmd;
static Tcl_ObjCmdProc NamespaceChildrenCmd;
static Tcl_ObjCmdProc NamespaceCodeCmd;
static Tcl_ObjCmdProc NamespaceCurrentCmd;
@@ -133,6 +133,22 @@ static const Tcl_ObjType nsNameType = {
SetNsNameFromAny /* setFromAnyProc */
};
+#define NsNameSetInternalRep(objPtr, nnPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (nnPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (nnPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &nsNameType, &ir); \
+ } while (0)
+
+#define NsNameGetInternalRep(objPtr, nnPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &nsNameType); \
+ (nnPtr) = irPtr ? (ResolvedNsName *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
@@ -290,7 +306,7 @@ Tcl_PushCallFrame(
/*
* TODO: Examine whether it would be better to guard based on NS_DYING
- * or NS_KILLED. It appears that these are not tested because they can
+ * or NS_TEARDOWN. It appears that these are not tested because they can
* be set in a global interp that has been [namespace delete]d, but
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
@@ -380,7 +396,7 @@ Tcl_PopCallFrame(
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
- if (--framePtr->localCachePtr->refCount == 0) {
+ if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
@@ -401,6 +417,8 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
+ /* Reusing the existing reference count from framePtr->tailcallPtr, so
+ * no need to Tcl_IncrRefCount(framePtr->tailcallPtr)*/
TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -477,11 +495,11 @@ TclPopStackFrame(
static char *
EstablishErrorCodeTraces(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorCodeRead, NULL);
@@ -509,11 +527,11 @@ EstablishErrorCodeTraces(
static char *
ErrorCodeRead(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
@@ -551,11 +569,11 @@ ErrorCodeRead(
static char *
EstablishErrorInfoTraces(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorInfoRead, NULL);
@@ -583,11 +601,11 @@ EstablishErrorInfoTraces(
static char *
ErrorInfoRead(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
@@ -970,20 +988,21 @@ Tcl_DeleteNamespace(
}
/*
- * If the namespace is on the call frame stack, it is marked as "dying"
- * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
- * name but its commands and variables are still usable by those active
- * call frames. When all active call frames referring to the namespace
- * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
- * function again to delete everything in the namespace. If no nsName
- * objects refer to the namespace (i.e., if its refCount is zero), its
- * commands and variables are deleted and the storage for its namespace
- * structure is freed. Otherwise, if its refCount is nonzero, the
- * namespace's commands and variables are deleted but the structure isn't
- * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
- * namespace resolution code to recognize that the namespace is "deleted".
- * The structure's storage is freed by FreeNsNameInternalRep when its
- * refCount reaches 0.
+ * If the namespace is on the call frame stack, it is marked as "dying"
+ * (NS_DYING is OR'd into its flags): Contents of the namespace are
+ * still available and visible until the namespace is later marked as
+ * NS_DEAD, and its commands and variables are still usable by any
+ * active call frames referring to th namespace. When all active call
+ * frames referring to the namespace have been popped from the Tcl
+ * stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no
+ * nsName objects refer to the namespace (i.e., if its refCount is
+ * zero), its commands and variables are deleted and the storage for
+ * its namespace structure is freed. Otherwise, if its refCount is
+ * nonzero, the namespace's commands and variables are deleted but the
+ * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
+ * flags to allow the namespace resolution code to recognize that the
+ * namespace is "deleted". The structure's storage is freed by
+ * FreeNsNameInternalRep when its refCount reaches 0.
*/
if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
@@ -997,16 +1016,16 @@ Tcl_DeleteNamespace(
}
}
nsPtr->parentPtr = NULL;
- } else if (!(nsPtr->flags & NS_KILLED)) {
+ } else if (!(nsPtr->flags & NS_TEARDOWN)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
- * interpreter is being torn down. Set the NS_KILLED flag to avoid
+ * interpreter is being torn down. Set the NS_TEARDOWN flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
- nsPtr->flags |= (NS_DYING|NS_KILLED);
+ nsPtr->flags |= (NS_DYING|NS_TEARDOWN);
TclTeardownNamespace(nsPtr);
@@ -1044,7 +1063,7 @@ Tcl_DeleteNamespace(
* get killed later, avoiding mem leaks.
*/
- nsPtr->flags &= ~(NS_DYING|NS_KILLED);
+ nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN);
}
}
TclNsDecrRefCount(nsPtr);
@@ -1057,6 +1076,83 @@ TclNamespaceDeleted(
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
+void
+TclDeleteNamespaceChildren(
+ Namespace *nsPtr /* Namespace whose children to delete */
+)
+{
+ Interp *iPtr = (Interp *) nsPtr->interp;
+ Tcl_HashEntry *entryPtr;
+ int i, unchecked;
+ Tcl_HashSearch search;
+ /*
+ * Delete all the child namespaces.
+ *
+ * BE CAREFUL: When each child is deleted, it divorces itself from its
+ * parent. The hash table can't be proplery traversed if its elements are
+ * being deleted. Because of traces (and the desire to avoid the
+ * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
+ * f97d4ee020]) copy to a temporary array and then delete all those
+ * namespaces.
+ *
+ * Important: leave the hash table itself still live.
+ */
+
+#ifndef BREAK_NAMESPACE_COMPAT
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTable.numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTablePtr->numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+ }
+#endif
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1165,62 +1261,7 @@ TclTeardownNamespace(
nsPtr->commandPathSourceList = NULL;
}
- /*
- * Delete all the child namespaces.
- *
- * BE CAREFUL: When each child is deleted, it will divorce itself from its
- * parent. You can't traverse a hash table properly if its elements are
- * being deleted. Because of traces (and the desire to avoid the
- * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
- * f97d4ee020]) we copy to a temporary array and then delete all those
- * namespaces.
- *
- * Important: leave the hash table itself still live.
- */
-
-#ifndef BREAK_NAMESPACE_COMPAT
- while (nsPtr->childTable.numEntries > 0) {
- int length = nsPtr->childTable.numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
-#else
- if (nsPtr->childTablePtr != NULL) {
- while (nsPtr->childTablePtr->numEntries > 0) {
- int length = nsPtr->childTablePtr->numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
- }
-#endif
+ TclDeleteNamespaceChildren(nsPtr);
/*
* Free the namespace's export pattern array.
@@ -1308,8 +1349,7 @@ void
TclNsDecrRefCount(
Namespace *nsPtr)
{
- nsPtr->refCount--;
- if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
+ if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
}
@@ -1752,9 +1792,11 @@ DoImport(
dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
+ /* corresponding decrement is in DeleteImportedCmd */
+ cmdPtr->refCount++;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
@@ -1973,7 +2015,7 @@ TclGetOriginalCommand(
/*
*----------------------------------------------------------------------
*
- * InvokeImportedCmd --
+ * TclInvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that was
* created by Tcl_Import. Finds the "real" command (in another
@@ -2004,8 +2046,8 @@ InvokeImportedNRCmd(
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
-static int
-InvokeImportedCmd(
+int
+TclInvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -2062,6 +2104,7 @@ DeleteImportedCmd(
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
+ TclCleanupCommandMacro(realCmdPtr);
ckfree(dataPtr);
return;
}
@@ -2600,7 +2643,7 @@ Tcl_FindCommand(
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
- || !(realNsPtr->flags & NS_DYING)) {
+ || !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2612,7 +2655,7 @@ Tcl_FindCommand(
* Next, check along the path.
*/
- for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
+ for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) {
pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
if (pathNsPtr == NULL) {
continue;
@@ -2621,7 +2664,7 @@ Tcl_FindCommand(
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2639,7 +2682,7 @@ Tcl_FindCommand(
TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2886,26 +2929,29 @@ GetNamespaceFromObj(
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
- Namespace *nsPtr, *refNsPtr;
- if (objPtr->typePtr == &nsNameType) {
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ if (resNamePtr) {
+ Namespace *nsPtr, *refNsPtr;
+
/*
* Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
*/
- 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))))){
+ if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
+ && (!refNsPtr || (refNsPtr ==
+ (Namespace *) TclGetCurrentNamespace(interp)))) {
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
+ Tcl_StoreInternalRep(objPtr, &nsNameType, NULL);
}
if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
@@ -2959,7 +3005,7 @@ TclInitNamespaceCmd(
static int
NamespaceChildrenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3088,7 +3134,7 @@ NamespaceChildrenCmd(
static int
NamespaceCodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3169,7 +3215,7 @@ NamespaceCodeCmd(
static int
NamespaceCurrentCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3232,7 +3278,7 @@ NamespaceCurrentCmd(
static int
NamespaceDeleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3256,7 +3302,7 @@ NamespaceDeleteCmd(
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
- || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
+ || (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\" in namespace delete command",
TclGetString(objv[i])));
@@ -3320,7 +3366,7 @@ NamespaceEvalCmd(
static int
NRNamespaceEvalCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3452,7 +3498,7 @@ NsEval_Callback(
static int
NamespaceExistsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3507,7 +3553,7 @@ NamespaceExistsCmd(
static int
NamespaceExportCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3589,7 +3635,7 @@ NamespaceExportCmd(
static int
NamespaceForgetCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3654,7 +3700,7 @@ NamespaceForgetCmd(
static int
NamespaceImportCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3769,7 +3815,7 @@ NamespaceInscopeCmd(
static int
NRNamespaceInscopeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3866,12 +3912,12 @@ NRNamespaceInscopeCmd(
static int
NamespaceOriginCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Command command, origCommand;
+ Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
@@ -3879,30 +3925,29 @@ NamespaceOriginCmd(
return TCL_ERROR;
}
- command = Tcl_GetCommandFromObj(interp, objv[1]);
- if (command == NULL) {
+ cmd = Tcl_GetCommandFromObj(interp, objv[1]);
+ if (cmd == NULL) {
+ goto namespaceOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+ TclNewObj(resultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, resultPtr);
+ if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(resultPtr);
+ namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
- origCommand = TclGetOriginalCommand(command);
- TclNewObj(resultPtr);
- if (origCommand == NULL) {
- /*
- * The specified command isn't an imported command. Return the
- * command's name qualified by the full name of the namespace it was
- * defined in.
- */
-
- Tcl_GetCommandFullName(interp, command, resultPtr);
- } else {
- Tcl_GetCommandFullName(interp, origCommand, resultPtr);
- }
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
+
/*
*----------------------------------------------------------------------
@@ -3927,7 +3972,7 @@ NamespaceOriginCmd(
static int
NamespaceParentCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3985,7 +4030,7 @@ NamespaceParentCmd(
static int
NamespacePathCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4022,7 +4067,7 @@ NamespacePathCmd(
* There is a path given, so parse it into an array of namespace pointers.
*/
- if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
@@ -4211,7 +4256,7 @@ TclInvalidateNsPath(
static int
NamespaceQualifiersCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4279,7 +4324,7 @@ NamespaceQualifiersCmd(
static int
NamespaceUnknownCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4390,7 +4435,7 @@ Tcl_SetNamespaceUnknownHandler(
*/
if (handlerPtr != NULL) {
- if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
+ if (TclListObjLengthM(interp, handlerPtr, &lstlen) != TCL_OK) {
/*
* Not a list.
*/
@@ -4466,7 +4511,7 @@ Tcl_SetNamespaceUnknownHandler(
static int
NamespaceTailCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4524,7 +4569,7 @@ NamespaceTailCmd(
static int
NamespaceUpvarCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4598,7 +4643,7 @@ NamespaceUpvarCmd(
static int
NamespaceWhichCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4677,15 +4722,17 @@ FreeNsNameInternalRep(
Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- ResolvedNsName *resNamePtr = (ResolvedNsName *)objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
+
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
/*
* Decrement the reference count of the namespace. If there are no more
* references, free it up.
*/
- resNamePtr->refCount--;
- if (resNamePtr->refCount == 0) {
+ if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
@@ -4695,7 +4742,6 @@ FreeNsNameInternalRep(
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -4722,11 +4768,11 @@ DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- resNamePtr->refCount++;
- copyPtr->typePtr = &nsNameType;
+ NsNameGetInternalRep(srcPtr, resNamePtr);
+ assert(resNamePtr != NULL);
+ NsNameSetInternalRep(copyPtr, resNamePtr);
}
/*
@@ -4771,36 +4817,25 @@ SetNsNameFromAny(
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+ if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
+ return TCL_ERROR;
+ }
+
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
- if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
- /*
- * Our failed lookup proves any previously cached nsName internalrep is no
- * longer valid. Get rid of it so we no longer waste memory storing
- * it, nor time determining its invalidity again and again.
- */
-
- if (objPtr->typePtr == &nsNameType) {
- TclFreeIntRep(objPtr);
- }
- return TCL_ERROR;
- }
-
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
- resNamePtr->refNsPtr = (Namespace *)Tcl_GetCurrentNamespace(interp);
+ resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
- resNamePtr->refCount = 1;
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- objPtr->typePtr = &nsNameType;
+ resNamePtr->refCount = 0;
+ NsNameSetInternalRep(objPtr, resNamePtr);
return TCL_OK;
}
@@ -4888,8 +4923,9 @@ TclLogCommandInfo(
* 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). */
+ int length, /* Number of bytes in command (TCL_INDEX_NONE
+ * 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 */
@@ -4976,7 +5012,7 @@ TclLogCommandInfo(
int len;
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
@@ -5010,7 +5046,7 @@ TclLogCommandInfo(
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj(
iPtr->framePtr->level - iPtr->varFramePtr->level));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
/*
@@ -5061,7 +5097,7 @@ TclErrorStackResetIf(
int len;
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index e76bca8..e17819e 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -7,9 +7,10 @@
* of the notifier is defined in the tcl*Notify.c files in each platform
* directory.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
- * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1998 Scriptics Corporation.
+ * Copyright © 2003 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2021 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,11 +19,11 @@
#include "tclInt.h"
/*
- * Module-scope struct of notifier hooks that are checked in the default
+ * Notifier hooks that are checked in the public wrappers for the default
* notifier functions (for overriding via Tcl_SetNotifier).
*/
-Tcl_NotifierProcs tclNotifierHooks = {
+static Tcl_NotifierProcs tclNotifierHooks = {
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL
};
@@ -94,8 +95,8 @@ TCL_DECLARE_MUTEX(listLock)
* Declarations for routines used only in this file.
*/
-static void QueueEvent(ThreadSpecificData *tsdPtr,
- Tcl_Event *evPtr, Tcl_QueuePosition position);
+static int QueueEvent(ThreadSpecificData *tsdPtr,
+ Tcl_Event *evPtr, int position);
/*
*----------------------------------------------------------------------
@@ -174,7 +175,7 @@ TclFinalizeNotifier(void)
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
- return; /* Notifier not initialized for the current thread */
+ return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
@@ -224,9 +225,41 @@ TclFinalizeNotifier(void)
void
Tcl_SetNotifier(
- Tcl_NotifierProcs *notifierProcPtr)
+ const Tcl_NotifierProcs *notifierProcPtr)
{
tclNotifierHooks = *notifierProcPtr;
+
+ /*
+ * Don't allow hooks to refer to the hook point functions; avoids infinite
+ * loop.
+ */
+
+ if (tclNotifierHooks.setTimerProc == Tcl_SetTimer) {
+ tclNotifierHooks.setTimerProc = NULL;
+ }
+ if (tclNotifierHooks.waitForEventProc == Tcl_WaitForEvent) {
+ tclNotifierHooks.waitForEventProc = NULL;
+ }
+ if (tclNotifierHooks.initNotifierProc == Tcl_InitNotifier) {
+ tclNotifierHooks.initNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.finalizeNotifierProc == Tcl_FinalizeNotifier) {
+ tclNotifierHooks.finalizeNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.alertNotifierProc == Tcl_AlertNotifier) {
+ tclNotifierHooks.alertNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.serviceModeHookProc == Tcl_ServiceModeHook) {
+ tclNotifierHooks.serviceModeHookProc = NULL;
+ }
+#ifndef _WIN32
+ if (tclNotifierHooks.createFileHandlerProc == Tcl_CreateFileHandler) {
+ tclNotifierHooks.createFileHandlerProc = NULL;
+ }
+ if (tclNotifierHooks.deleteFileHandlerProc == Tcl_DeleteFileHandler) {
+ tclNotifierHooks.deleteFileHandlerProc = NULL;
+ }
+#endif /* !_WIN32 */
}
/*
@@ -276,7 +309,7 @@ Tcl_CreateEventSource(
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- EventSource *sourcePtr = ckalloc(sizeof(EventSource));
+ EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
@@ -358,8 +391,8 @@ Tcl_QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -390,8 +423,8 @@ Tcl_ThreadQueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr;
@@ -410,7 +443,9 @@ Tcl_ThreadQueueEvent(
*/
if (tsdPtr) {
- QueueEvent(tsdPtr, evPtr, position);
+ if (QueueEvent(tsdPtr, evPtr, position)) {
+ Tcl_AlertNotifier(tsdPtr->clientData);
+ }
} else {
ckfree(evPtr);
}
@@ -430,7 +465,8 @@ Tcl_ThreadQueueEvent(
* last-in-first-out order.
*
* Results:
- * None.
+ * For TCL_QUEUE_ALERT_IF_EMPTY the empty state before the
+ * operation is returned.
*
* Side effects:
* None.
@@ -438,7 +474,7 @@ Tcl_ThreadQueueEvent(
*----------------------------------------------------------------------
*/
-static void
+static int
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
@@ -447,11 +483,14 @@ QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
- if (position == TCL_QUEUE_TAIL) {
+ if (tsdPtr->firstEventPtr != NULL) {
+ position &= ~TCL_QUEUE_ALERT_IF_EMPTY;
+ }
+ if ((position & 3) == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
@@ -463,7 +502,7 @@ QueueEvent(
tsdPtr->lastEventPtr->nextPtr = evPtr;
}
tsdPtr->lastEventPtr = evPtr;
- } else if (position == TCL_QUEUE_HEAD) {
+ } else if ((position & 3) == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
@@ -473,7 +512,7 @@ QueueEvent(
tsdPtr->lastEventPtr = evPtr;
}
tsdPtr->firstEventPtr = evPtr;
- } else if (position == TCL_QUEUE_MARK) {
+ } else if ((position & 3) == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance the
* marker to the new event.
@@ -492,6 +531,7 @@ QueueEvent(
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+ return position & TCL_QUEUE_ALERT_IF_EMPTY;
}
/*
@@ -794,7 +834,7 @@ Tcl_SetServiceMode(
void
Tcl_SetMaxBlockTime(
- const 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-> */
{
@@ -1133,6 +1173,260 @@ Tcl_ThreadAlert(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * Initializes the platform specific notifier state. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread..
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_InitNotifier(void)
+{
+ if (tclNotifierHooks.initNotifierProc) {
+ return tclNotifierHooks.initNotifierProc();
+ } else {
+ return TclpInitNotifier();
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeNotifier --
+ *
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated. Forwards to the platform implementation when the hook
+ * is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If no finalizeNotifierProc notifier hook exists, TclpFinalizeNotifier
+ * is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FinalizeNotifier(
+ ClientData clientData)
+{
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ } else {
+ TclpFinalizeNotifier(clientData);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AlertNotifier --
+ *
+ * Wake up the specified notifier from any thread. This routine is called
+ * by the platform independent notifier code whenever the Tcl_ThreadAlert
+ * routine is called. This routine is guaranteed not to be called by Tcl
+ * on a given notifier after Tcl_FinalizeNotifier is called for that
+ * notifier. This routine is typically called from a thread other than
+ * the notifier's thread. Forwards to the platform implementation when
+ * the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AlertNotifier(
+ ClientData clientData) /* Pointer to thread data. */
+{
+ if (tclNotifierHooks.alertNotifierProc) {
+ tclNotifierHooks.alertNotifierProc(clientData);
+ } else {
+ TclpAlertNotifier(clientData);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ServiceModeHook --
+ *
+ * This function is invoked whenever the service mode changes. Forwards
+ * to the platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ServiceModeHook(
+ int mode) /* Either TCL_SERVICE_ALL, or
+ * TCL_SERVICE_NONE. */
+{
+ if (tclNotifierHooks.serviceModeHookProc) {
+ tclNotifierHooks.serviceModeHookProc(mode);
+ } else {
+ TclpServiceModeHook(mode);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetTimer --
+ *
+ * This function sets the current notifier timer value. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetTimer(
+ const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
+{
+ if (tclNotifierHooks.setTimerProc) {
+ tclNotifierHooks.setTimerProc(timePtr);
+ } else {
+ TclpSetTimer(timePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the notifier's message queue. If the block time is 0, then
+ * Tcl_WaitForEvent just polls without blocking. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * Returns -1 if the wait would block forever, 1 if an out-of-loop source
+ * was processed (see platform-specific notes) and otherwise returns 0.
+ *
+ * Side effects:
+ * Queues file events that are detected by the notifier.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_WaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ return TclpWaitForEvent(timePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateFileHandler --
+ *
+ * This function registers a file descriptor handler with the notifier.
+ * Forwards to the platform implementation when the hook is not enabled.
+ *
+ * This function is not defined on Windows. The OS API there is too
+ * different.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new file handler structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef _WIN32
+void
+Tcl_CreateFileHandler(
+ int fd, /* Handle of stream to watch. */
+ int mask, /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, and TCL_EXCEPTION: indicates
+ * conditions under which proc should be
+ * called. */
+ Tcl_FileProc *proc, /* Function to call for each selected
+ * event. */
+ ClientData clientData) /* Arbitrary data to pass to proc. */
+{
+ if (tclNotifierHooks.createFileHandlerProc) {
+ tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData);
+ } else {
+ TclpCreateFileHandler(fd, mask, proc, clientData);
+ }
+}
+#endif /* !_WIN32 */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for a file
+ * descriptor. Forwards to the platform implementation when the hook is
+ * not enabled.
+ *
+ * This function is not defined on Windows. The OS API there is too
+ * different.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on the file descriptor, remove
+ * it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef _WIN32
+void
+Tcl_DeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ if (tclNotifierHooks.deleteFileHandlerProc) {
+ tclNotifierHooks.deleteFileHandlerProc(fd);
+ } else {
+ TclpDeleteFileHandler(fd);
+ }
+}
+#endif /* !_WIN32 */
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 043aa4c..5bd687a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -3,8 +3,8 @@
*
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
- * Copyright (c) 2005-2012 by Donal K. Fellows
- * Copyright (c) 2017 by Nathan Coulter
+ * Copyright © 2005-2012 Donal K. Fellows
+ * Copyright © 2017 Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -26,11 +26,13 @@ static const struct {
int flag;
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
+ {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
+ {"private", TclOODefinePrivateObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
@@ -41,7 +43,9 @@ static const struct {
{"export", TclOODefineExportObjCmd, 1},
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
+ {"private", TclOODefinePrivateObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+ {"self", TclOODefineObjSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 1},
{NULL, NULL, 0}
};
@@ -69,31 +73,28 @@ static void DeletedHelpersNamespace(ClientData clientData);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
static Tcl_NRPostProc FinalizeObjectCall;
-static void initClassPath(Tcl_Interp * interp, Class *clsPtr);
+static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr);
+static void InitClassSystemRoots(Tcl_Interp *interp,
+ Foundation *fPtr);
static int InitFoundation(Tcl_Interp *interp);
-static void KillFoundation(ClientData clientData,
- Tcl_Interp *interp);
+static Tcl_InterpDeleteProc KillFoundation;
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 Tcl_CommandTraceProc ObjectRenamedTrace;
+static inline void RemoveClass(Class **list, int num, int idx);
+static inline void RemoveObject(Object **list, int num, int idx);
static inline void SquelchCachedName(Object *oPtr);
-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,
+static int PrivateNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateNRObjectCmd(ClientData clientData,
+static int MyClassNRObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static void RemoveClass(Class ** list, int num, int idx);
-static void RemoveObject(Object ** list, int num, int idx);
+static void MyClassDeleted(ClientData clientData);
/*
* Methods in the oo::object and oo::class classes. First, we define a helper
@@ -137,72 +138,20 @@ static const Tcl_MethodType classConstructor = {
*/
static const char initScript[] =
+#ifndef TCL_NO_DEPRECATED
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
+#endif
+"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"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;"; */
/*
- * The scripted part of the definitions of slots.
+ * The scripted part of the definitions of TclOO.
*/
-static const char *slotScript =
-"::oo::define ::oo::Slot {\n"
-" method Get {} {error unimplemented}\n"
-" method Set list {error unimplemented}\n"
-" method -set args {\n"
-" uplevel 1 [list [namespace which my] Set $args]\n"
-" }\n"
-" method -append args {\n"
-" uplevel 1 [list [namespace which my] Set [list"
-" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
-" }\n"
-" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
-" forward --default-operation my -append\n"
-" method unknown {args} {\n"
-" set def --default-operation\n"
-" if {[llength $args] == 0} {\n"
-" return [uplevel 1 [list [namespace which my] $def]]\n"
-" } elseif {![string match -* [lindex $args 0]]} {\n"
-" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
-" }\n"
-" next {*}$args\n"
-" }\n"
-" export -set -append -clear\n"
-" unexport unknown destroy\n"
-"}\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
-"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
-
-/*
- * The body of the <cloned> method of oo::object.
- */
-
-static const char *clonedBody =
-"foreach p [info procs [info object namespace $originObject]::*] {"
-" set args [info args $p];"
-" set idx -1;"
-" foreach a $args {"
-" lset args [incr idx] "
-" [if {[info default $p $a d]} {list $a $d} {list $a}]"
-" };"
-" set b [info body $p];"
-" set p [namespace tail $p];"
-" proc $p $args $b;"
-"};"
-"foreach v [info vars [info object namespace $originObject]::*] {"
-" upvar 0 $v vOrigin;"
-" namespace upvar [namespace current] [namespace tail $v] vNew;"
-" if {[info exists vOrigin]} {"
-" if {[array exists vOrigin]} {"
-" array set vNew [array get vOrigin];"
-" } else {"
-" set vNew $vOrigin;"
-" }"
-" }"
-"}";
+#include "tclOOScript.h"
/*
* The actual definition of the variable holding the TclOO stub table.
@@ -232,14 +181,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
#define RemoveItem(type, lst, i) \
- do { \
- Remove ## type ((lst).list, (lst).num, i); \
- (lst).num--; \
+ do { \
+ Remove ## type ((lst).list, (lst).num, i); \
+ (lst).num--; \
} while (0)
/*
* ----------------------------------------------------------------------
*
+ * RemoveClass, RemoveObject --
+ *
+ * Helpers for the RemoveItem macro for deleting a class or object from a
+ * list. Setting the "empty" location to NULL makes debugging a little
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RemoveClass(
+ Class **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+static inline void
+RemoveObject(
+ Object **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOInit --
*
* Called to initialise the OO system within an interpreter.
@@ -271,11 +256,15 @@ TclOOInit(
* to be fully provided.
*/
- if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
+#ifndef TCL_NO_DEPRECATED
+ Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
+ &tclOOStubs);
+#endif
+ return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
@@ -314,13 +303,9 @@ InitFoundation(
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
- Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
- Foundation *fPtr = ckalloc(sizeof(Foundation));
- Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
-
- Class fakeCls;
- Object fakeObject;
-
+ (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation));
+ Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
@@ -383,28 +368,98 @@ InitFoundation(
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
- * Create the objects at the core of the object system. These need to be
- * spliced manually.
+ * Create the special objects at the core of the object system.
*/
+ InitClassSystemRoots(interp, fPtr);
+
/*
- * Stand up a phony class for bootstrapping.
+ * Basic method declarations for the core classes.
*/
- fPtr->objectCls = &fakeCls;
+ 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]);
+ }
/*
- * Referenced in TclOOAllocClass to increment the refCount.
+ * 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.
*/
- fakeCls.thisPtr = &fakeObject;
+ TclNewLiteralStringObj(namePtr, "new");
+ TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
+ fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
+ NULL, TclOONextObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextCmd;
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+ NULL, TclOONextToObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextToCmd;
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+ TclOOSelfObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectSelfCmd;
+ 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);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
- fPtr->objectCls = TclOOAllocClass(interp,
- AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
/*
- * Corresponding TclOODecrRefCount in KillFoudation.
+ * Evaluate the remaining definitions, which are a compiled-in Tcl script.
*/
+ return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitClassSystemRoots --
+ *
+ * Creates the objects at the core of the object system. These need to be
+ * spliced manually.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InitClassSystemRoots(
+ Tcl_Interp *interp,
+ Foundation *fPtr)
+{
+ Class fakeCls;
+ Object fakeObject;
+ Tcl_Obj *defNsName;
+
+ /* Stand up a phony class for bootstrapping. */
+ fPtr->objectCls = &fakeCls;
+ /* referenced in TclOOAllocClass to increment the refCount. */
+ fakeCls.thisPtr = &fakeObject;
+
+ fPtr->objectCls = TclOOAllocClass(interp,
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->objectCls->thisPtr);
/*
@@ -423,14 +478,13 @@ InitFoundation(
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
+ TclNewLiteralStringObj(defNsName, "::oo::objdefine");
+ fPtr->objectCls->objDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
-
- /*
- * Corresponding TclOODecrRefCount in KillFoudation.
- */
-
+ /* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->classCls->thisPtr);
/*
@@ -455,77 +509,17 @@ InitFoundation(
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
fPtr->classCls->flags |= ROOT_CLASS;
+ TclNewLiteralStringObj(defNsName, "::oo::define");
+ fPtr->classCls->clsDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
- /*
- * Standard initialization for new Objects.
- */
-
+ /* Standard initialization for new Objects */
TclOOAddToSubclasses(fPtr->classCls, 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]);
- }
-
- /*
- * Create the default <cloned> method implementation, used when 'oo::copy'
- * is called to finish the copying of one object to another.
+ * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
+ * Everything else is careful to prohibit looping.
*/
-
- TclNewLiteralStringObj(argsPtr, "originObject");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(clonedBody, -1);
- TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
- bodyPtr, NULL);
- TclDecrRefCount(argsPtr);
-
- /*
- * 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.
- */
-
- TclNewLiteralStringObj(namePtr, "new");
- Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
- namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
- fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
- (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
-
- /*
- * Create non-object commands and plug ourselves into the Tcl [info]
- * ensemble.
- */
-
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
- NULL, TclOONextObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextCmd;
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
- NULL, TclOONextToObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextToCmd;
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
- TclOOSelfObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectSelfCmd;
- 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);
-
- /*
- * Now make the class of slots.
- */
-
- if (TclOODefineSlots(fPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- return Tcl_Eval(interp, slotScript);
}
/*
@@ -543,7 +537,7 @@ static void
DeletedDefineNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
@@ -552,7 +546,7 @@ static void
DeletedObjdefNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
@@ -561,7 +555,7 @@ static void
DeletedHelpersNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->helpersNs = NULL;
}
@@ -579,10 +573,9 @@ DeletedHelpersNamespace(
static void
KillFoundation(
- ClientData clientData, /* Pointer to the OO system foundation
- * structure. */
- Tcl_Interp *interp) /* The interpreter containing the OO system
- * foundation. */
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
{
Foundation *fPtr = GetFoundation(interp);
@@ -620,8 +613,8 @@ AllocObject(
* if the OO system should pick the object
* name itself (equal to the namespace
* name). */
- Namespace *nsPtr, /* The namespace to create the object in,
- or NULL if *nameStr is NULL */
+ Namespace *nsPtr, /* The namespace to create the object in, or
+ * NULL if *nameStr is NULL */
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
@@ -634,7 +627,7 @@ AllocObject(
CommandTrace *tracePtr;
int creationEpoch;
- oPtr = ckalloc(sizeof(Object));
+ oPtr = (Object *)ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -718,8 +711,8 @@ AllocObject(
* destruction it occur: A call to ObjectRenamedTrace(), and a call to
* ObjectNamespaceDeleted().
*/
- oPtr->refCount = 2;
+ oPtr->refCount = 2;
oPtr->flags = USE_CLASS_CACHE;
/*
@@ -734,10 +727,9 @@ AllocObject(
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
-
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
- (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
+ (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -746,7 +738,7 @@ AllocObject(
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
- cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
+ cmdPtr->tracePtr = tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = ObjectRenamedTrace;
tracePtr->clientData = oPtr;
tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
@@ -754,7 +746,10 @@ AllocObject(
tracePtr->refCount = 1;
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
- PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
+ oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
+ MyClassDeleted);
return oPtr;
}
@@ -782,12 +777,12 @@ SquelchCachedName(
/*
* ----------------------------------------------------------------------
*
- * MyDeleted --
+ * MyDeleted, MyClassDeleted --
*
- * 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.
+ * These callbacks are triggered when the object's [my] or [myclass]
+ * commands are deleted by any mechanism. They just mark the object as
+ * not having a [my] command or [myclass] command, and so prevent cleanup
+ * of those commands when the object itself is deleted.
*
* ----------------------------------------------------------------------
*/
@@ -797,10 +792,18 @@ MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ ClientData clientData)
+{
+ Object *oPtr = (Object *)clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -818,12 +821,13 @@ MyDeleted(
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, /* What it's getting renamed to. (unused) */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(const char *) /*oldName*/,
+ TCL_UNUSED(const char *) /*newName*/,
int flags) /* Why was the object deleted? */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
+
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -891,6 +895,7 @@ TclOODeleteDescendants(
ckfree(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
+
/*
* Squelch subclasses of this class.
*/
@@ -960,6 +965,7 @@ TclOOReleaseClassContents(
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVariable;
/*
* Sanity check!
@@ -976,6 +982,19 @@ TclOOReleaseClassContents(
}
/*
+ * Stop using the class for definition information.
+ */
+
+ if (clsPtr->clsDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->clsDefinitionNs);
+ clsPtr->clsDefinitionNs = NULL;
+ }
+ if (clsPtr->objDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->objDefinitionNs);
+ clsPtr->objDefinitionNs = NULL;
+ }
+
+ /*
* Squelch method implementation chain caches.
*/
@@ -1063,6 +1082,14 @@ TclOOReleaseClassContents(
ckfree(clsPtr->variables.list);
}
+ FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
+ TclDecrRefCount(privateVariable->variableObj);
+ TclDecrRefCount(privateVariable->fullNameObj);
+ }
+ if (i) {
+ ckfree(clsPtr->privateVariables.list);
+ }
+
if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
@@ -1086,12 +1113,13 @@ ObjectNamespaceDeleted(
ClientData clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
+ PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
@@ -1100,6 +1128,7 @@ ObjectNamespaceDeleted(
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
+
return;
}
@@ -1108,6 +1137,7 @@ ObjectNamespaceDeleted(
* process of being deleted, nothing else may modify its bookeeping
* records. This is the flag that
*/
+
oPtr->flags |= OBJECT_DESTRUCTING;
/*
@@ -1127,7 +1157,7 @@ ObjectNamespaceDeleted(
if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
- TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
int result;
Tcl_InterpState state;
@@ -1154,7 +1184,7 @@ ObjectNamespaceDeleted(
* freed memory.
*/
- if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
+ if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
@@ -1168,6 +1198,9 @@ ObjectNamespaceDeleted(
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
+ if (oPtr->myclassCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+ }
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -1212,6 +1245,14 @@ ObjectNamespaceDeleted(
ckfree(oPtr->variables.list);
}
+ FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
+ TclDecrRefCount(privateVariable->variableObj);
+ TclDecrRefCount(privateVariable->fullNameObj);
+ }
+ if (i) {
+ ckfree(oPtr->privateVariables.list);
+ }
+
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
@@ -1244,7 +1285,6 @@ ObjectNamespaceDeleted(
if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
&& !Tcl_InterpDeleted(interp)) {
-
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1267,7 +1307,7 @@ ObjectNamespaceDeleted(
/*
* ----------------------------------------------------------------------
*
- * TclOODecrRef --
+ * TclOODecrRefCount --
*
* Decrement the refcount of an object and deallocate storage then object
* is no longer referenced. Returns 1 if storage was deallocated, and 0
@@ -1275,8 +1315,13 @@ ObjectNamespaceDeleted(
*
* ----------------------------------------------------------------------
*/
-int TclOODecrRefCount(Object *oPtr) {
+
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
if (oPtr->refCount-- <= 1) {
+
if (oPtr->classPtr != NULL) {
ckfree(oPtr->classPtr);
}
@@ -1301,21 +1346,6 @@ int TclOOObjectDestroyed(Object *oPtr) {
}
/*
- * Setting the "empty" location to NULL makes debugging a little easier.
- */
-
-#define REMOVEBODY { \
- for (; idx < num - 1; idx++) { \
- list[idx] = list[idx + 1]; \
- } \
- list[idx] = NULL; \
- return; \
-}
-void RemoveClass(Class **list, int num, int idx) REMOVEBODY
-
-void RemoveObject(Object **list, int num, int idx) REMOVEBODY
-
-/*
* ----------------------------------------------------------------------
*
* TclOORemoveFromInstances --
@@ -1367,9 +1397,9 @@ TclOOAddToInstances(
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);
+ clsPtr->instances.list = (Object **)ckalloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
- clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
+ clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list,
sizeof(Object *) * clsPtr->instances.size);
}
}
@@ -1466,9 +1496,9 @@ TclOOAddToSubclasses(
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);
+ superPtr->subclasses.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
+ superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
@@ -1531,9 +1561,9 @@ TclOOAddToMixinSubs(
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);
+ superPtr->mixinSubs.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
+ superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list,
sizeof(Class *) * superPtr->mixinSubs.size);
}
}
@@ -1552,6 +1582,25 @@ TclOOAddToMixinSubs(
* ----------------------------------------------------------------------
*/
+static inline void
+InitClassPath(
+ Tcl_Interp *interp,
+ Class *clsPtr)
+{
+ Foundation *fPtr = GetFoundation(interp);
+
+ 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 *
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
@@ -1560,7 +1609,7 @@ TclOOAllocClass(
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
- Class *clsPtr = ckalloc(sizeof(Class));
+ Class *clsPtr = (Class *)ckalloc(sizeof(Class));
memset(clsPtr, 0, sizeof(Class));
clsPtr->thisPtr = useThisObj;
@@ -1568,7 +1617,8 @@ TclOOAllocClass(
/*
* Configure the namespace path for the class's object.
*/
- initClassPath(interp, clsPtr);
+
+ InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
@@ -1576,7 +1626,7 @@ TclOOAllocClass(
*/
clsPtr->superclasses.num = 1;
- clsPtr->superclasses.list = ckalloc(sizeof(Class *));
+ clsPtr->superclasses.list = (Class **)ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
@@ -1594,19 +1644,6 @@ TclOOAllocClass(
Tcl_InitObjHashTable(&clsPtr->classMethods);
return clsPtr;
}
-static void
-initClassPath(Tcl_Interp *interp, Class *clsPtr) {
- Foundation *fPtr = GetFoundation(interp);
- 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);
- }
-}
/*
* ----------------------------------------------------------------------
@@ -1637,7 +1674,9 @@ Tcl_NewObjectInstance(
ClientData clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return NULL;}
+ if (oPtr == NULL) {
+ return NULL;
+ }
/*
* Run constructors, except when objc < 0, which is a special flag case
@@ -1646,7 +1685,7 @@ Tcl_NewObjectInstance(
if (objc >= 0) {
CallContext *contextPtr =
- TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr != NULL) {
int isRoot, result;
@@ -1706,7 +1745,9 @@ TclNRNewObjectInstance(
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return TCL_ERROR;}
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1717,7 +1758,7 @@ TclNRNewObjectInstance(
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
}
- contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr == NULL) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
@@ -1756,8 +1797,8 @@ TclNewObjectInstanceCommon(
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
const char *simpleName = NULL;
- Namespace *nsPtr = NULL, *dummy,
- *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = NULL, *dummy;
+ Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (nameStr) {
TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
@@ -1813,14 +1854,14 @@ FinalizeAlloc(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = data[0];
- Object *oPtr = data[1];
- Tcl_InterpState state = data[2];
- Tcl_Object *objectPtr = data[3];
+ CallContext *contextPtr = (CallContext *)data[0];
+ Object *oPtr = (Object *)data[1];
+ Tcl_InterpState state = (Tcl_InterpState)data[2];
+ Tcl_Object *objectPtr = (Tcl_Object *)data[3];
/*
- * Ensure an error if the object was deleted in the constructor.
- * Don't want to lose errors by accident. [Bug 2903011]
+ * Ensure an error if the object was deleted in the constructor. Don't
+ * want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Destructing(oPtr)) {
@@ -1886,6 +1927,7 @@ Tcl_CopyObjectInstance(
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ PrivateVariableMapping *privateVariable;
int i, result;
/*
@@ -1959,7 +2001,7 @@ Tcl_CopyObjectInstance(
}
/*
- * Copy the object's variable resolution list to the new object.
+ * Copy the object's variable resolution lists to the new object.
*/
DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
@@ -1967,6 +2009,13 @@ Tcl_CopyObjectInstance(
Tcl_IncrRefCount(variableObj);
}
+ DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
+ PrivateVariableMapping);
+ FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
+ Tcl_IncrRefCount(privateVariable->variableObj);
+ Tcl_IncrRefCount(privateVariable->fullNameObj);
+ }
+
/*
* 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
@@ -2028,11 +2077,11 @@ Tcl_CopyObjectInstance(
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
- cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
+ cls2Ptr->superclasses.list = (Class **) ckrealloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list =
- ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
+ (Class **)ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
@@ -2058,7 +2107,7 @@ Tcl_CopyObjectInstance(
}
/*
- * Copy the source class's variable resolution list.
+ * Copy the source class's variable resolution lists.
*/
DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
@@ -2066,6 +2115,13 @@ Tcl_CopyObjectInstance(
Tcl_IncrRefCount(variableObj);
}
+ DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
+ PrivateVariableMapping);
+ FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
+ Tcl_IncrRefCount(privateVariable->variableObj);
+ Tcl_IncrRefCount(privateVariable->fullNameObj);
+ }
+
/*
* Duplicate the source class's mixins (which cannot be circular
* references to the duplicate).
@@ -2142,7 +2198,8 @@ Tcl_CopyObjectInstance(
}
TclResetRewriteEnsemble(interp, 1);
- contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
+ NULL, NULL);
if (contextPtr) {
args[0] = TclOOObjectName(interp, o2Ptr);
args[1] = oPtr->fPtr->clonedName;
@@ -2189,7 +2246,7 @@ CloneObjectMethod(
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2198,10 +2255,10 @@ CloneObjectMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
} else {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
}
return TCL_OK;
@@ -2218,7 +2275,7 @@ CloneClassMethod(
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2227,11 +2284,11 @@ CloneClassMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
@@ -2318,7 +2375,7 @@ Tcl_ClassSetMetadata(
if (metadata == NULL) {
return;
}
- clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2398,7 +2455,7 @@ Tcl_ObjectSetMetadata(
if (metadata == NULL) {
return;
}
- oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2430,7 +2487,7 @@ Tcl_ObjectSetMetadata(
/*
* ----------------------------------------------------------------------
*
- * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject --
*
* Main entry point for object invocations. The Public* and Private*
* wrapper functions (implementations of both object instance commands
@@ -2440,8 +2497,8 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
+int
+TclOOPublicObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2457,12 +2514,12 @@ PublicNRObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
+ return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
NULL);
}
-static int
-PrivateObjectCmd(
+int
+TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2478,7 +2535,7 @@ PrivateNRObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
+ return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
}
int
@@ -2515,6 +2572,43 @@ TclOOInvokeObject(
/*
* ----------------------------------------------------------------------
*
+ * TclOOMyClassObjCmd, MyClassNRObjCmd --
+ *
+ * Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOMyClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *)clientData;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+ return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
+ NULL);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOObjectCmdCore, FinalizeObjectCall --
*
* Main function for object invocations. Does call chain creation,
@@ -2539,6 +2633,9 @@ TclOOObjectCmdCore(
{
CallContext *contextPtr;
Tcl_Obj *methodNamePtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+ Object *callerObjPtr = NULL;
+ Class *callerClsPtr = NULL;
int result;
/*
@@ -2553,6 +2650,24 @@ TclOOObjectCmdCore(
}
/*
+ * Determine if we're in a context that can see the extra, private methods
+ * in this class.
+ */
+
+ if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+ CallContext *callerContextPtr = (CallContext *)framePtr->clientData;
+ Method *callerMethodPtr =
+ callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
+
+ if (callerMethodPtr->declaringObjectPtr) {
+ callerObjPtr = callerMethodPtr->declaringObjectPtr;
+ }
+ if (callerMethodPtr->declaringClassPtr) {
+ callerClsPtr = callerMethodPtr->declaringClassPtr;
+ }
+ }
+
+ /*
* Give plugged in code a chance to remap the method name.
*/
@@ -2579,7 +2694,8 @@ TclOOObjectCmdCore(
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
- flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+ flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+ callerClsPtr, methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2596,7 +2712,8 @@ TclOOObjectCmdCore(
noMapping:
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
- flags | (oPtr->flags & FILTER_HANDLING), NULL);
+ flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+ callerClsPtr, NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
@@ -2647,7 +2764,7 @@ TclOOObjectCmdCore(
static int
FinalizeObjectCall(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
/*
@@ -2655,7 +2772,7 @@ FinalizeObjectCall(
* structure.
*/
- TclOODeleteContext(data[0]);
+ TclOODeleteContext((CallContext *)data[0]);
return result;
}
@@ -2808,10 +2925,10 @@ TclNRObjectContextInvokeNext(
static int
FinalizeNext(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -2846,13 +2963,13 @@ Tcl_GetObjectFromObj(
if (cmdPtr == NULL) {
goto notAnObject;
}
- if (cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
- return cmdPtr->objClientData;
+ return (Tcl_Object)cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3027,6 +3144,26 @@ Tcl_ObjectSetMethodNameMapper(
{
((Object *) object)->mapMethodNameProc = mapMethodNameProc;
}
+
+Tcl_Class
+Tcl_GetClassOfObject(
+ Tcl_Object object)
+{
+ return (Tcl_Class) ((Object *) object)->selfCls;
+}
+
+Tcl_Obj *
+Tcl_GetObjectClassName(
+ Tcl_Interp *interp,
+ Tcl_Object object)
+{
+ Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr;
+
+ if (classObj == NULL) {
+ return NULL;
+ }
+ return Tcl_GetObjectName(interp, classObj);
+}
/*
* Local Variables:
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 67b1996..c933872 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -58,12 +58,12 @@ declare 10 {
}
declare 11 {
Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
- Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
void *clientData)
}
declare 12 {
Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
- Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
void *clientData)
}
declare 13 {
@@ -126,8 +126,28 @@ declare 27 {
declare 28 {
Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
}
+declare 29 {
+ int Tcl_MethodIsPrivate(Tcl_Method method)
+}
+declare 30 {
+ Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
+}
+declare 31 {
+ Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
+}
+declare 32 {
+ int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+}
+declare 33 {
+ Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
declare 34 {
- void TclOOUnusedStubEntry(void)
+ Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
}
######################################################################
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 20dc281..6f18491 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,8 +24,8 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.1.0"
-#define TCLOO_PATCHLEVEL TCLOO_VERSION
+#define TCLOO_VERSION "1.3"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0"
#include "tcl.h"
@@ -40,7 +40,7 @@ extern "C" {
extern const char *TclOOInitializeStubs(
Tcl_Interp *, const char *version);
#define Tcl_OOInitStubs(interp) \
- TclOOInitializeStubs((interp), TCLOO_VERSION)
+ TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL)
#ifndef USE_TCL_STUBS
# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
#endif
@@ -62,6 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
@@ -77,7 +79,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
typedef struct {
int version; /* Structure version field. Always to be equal
- * to TCL_OO_METHOD_VERSION_CURRENT in
+ * to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
@@ -92,13 +94,41 @@ typedef struct {
* be copied directly. */
} Tcl_MethodType;
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_2 in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc2 *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_MethodType2;
+
/*
* 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 compatibility.
*/
+#define TCL_OO_METHOD_VERSION_1 1
+#define TCL_OO_METHOD_VERSION_2 2
#define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * Visibility constants for the flags parameter to Tcl_NewMethod and
+ * Tcl_NewInstanceMethod.
+ */
+
+#define TCL_OO_METHOD_PUBLIC 1
+#define TCL_OO_METHOD_UNEXPORTED 0
+#define TCL_OO_METHOD_PRIVATE 0x20
/*
* The type of some object (or class) metadata. This describes how to delete
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index e746b64..3593193 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -4,7 +4,7 @@
* This file contains implementations of the "simple" commands and
* methods from the object-system core.
*
- * Copyright (c) 2005-2013 by Donal K. Fellows
+ * Copyright © 2005-2013 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -55,7 +55,7 @@ FinalizeConstruction(
Tcl_Interp *interp,
int result)
{
- Object *oPtr = data[0];
+ Object *oPtr = (Object *)data[0];
if (result != TCL_OK) {
return result;
@@ -76,14 +76,14 @@ FinalizeConstruction(
int
TclOO_Class_Constructor(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj **invoke;
+ Tcl_Obj **invoke, *nameObj;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,10 +94,21 @@ TclOO_Class_Constructor(
}
/*
+ * Make the class definition delegate. This is special; it doesn't reenter
+ * here (and the class definition delegate doesn't run any constructors).
+ */
+
+ nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+ Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+ TclGetString(nameObj), NULL, -1, NULL, -1);
+ Tcl_DecrRefCount(nameObj);
+
+ /*
* Delegate to [oo::define] to do the work.
*/
- invoke = ckalloc(3 * sizeof(Tcl_Obj *));
+ invoke = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke, NULL, NULL, NULL);
+ invoke, oPtr, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -127,13 +138,28 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **invoke = data[0];
+ Tcl_Obj **invoke = (Tcl_Obj **)data[0];
+ Object *oPtr = (Object *)data[1];
+ Tcl_InterpState saved;
+ int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
+ invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ saved = Tcl_SaveInterpState(interp, result);
+ code = Tcl_EvalObjv(interp, 2, invoke, 0);
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
ckfree(invoke);
- return result;
+ if (code != TCL_OK) {
+ Tcl_DiscardInterpState(saved);
+ return code;
+ }
+ return Tcl_RestoreInterpState(interp, saved);
}
/*
@@ -148,7 +174,7 @@ DecrRefsPostClassConstructor(
int
TclOO_Class_Create(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -213,7 +239,7 @@ TclOO_Class_Create(
int
TclOO_Class_CreateNs(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -286,7 +312,7 @@ TclOO_Class_CreateNs(
int
TclOO_Class_New(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -330,7 +356,7 @@ TclOO_Class_New(
int
TclOO_Object_Destroy(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -347,7 +373,8 @@ TclOO_Object_Destroy(
}
if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
oPtr->flags |= DESTRUCTOR_CALLED;
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
+ NULL);
if (contextPtr != NULL) {
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
@@ -369,7 +396,7 @@ AfterNRDestructor(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
@@ -390,7 +417,7 @@ AfterNRDestructor(
int
TclOO_Object_Eval(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -456,7 +483,7 @@ FinalizeEval(
int result)
{
if (result == TCL_ERROR) {
- Object *oPtr = data[0];
+ Object *oPtr = (Object *)data[0];
const char *namePtr;
if (oPtr) {
@@ -491,7 +518,7 @@ FinalizeEval(
int
TclOO_Object_Unknown(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -499,9 +526,12 @@ TclOO_Object_Unknown(
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
+ Object *callerObj = NULL;
+ Class *callerCls = NULL;
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
Tcl_Obj *errorMsg;
/*
@@ -516,10 +546,31 @@ TclOO_Object_Unknown(
}
/*
+ * Determine if the calling context should know about extra private
+ * methods, and if so, which.
+ */
+
+ if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+ CallContext *callerContext = (CallContext *)framePtr->clientData;
+ Method *mPtr = callerContext->callPtr->chain[
+ callerContext->index].mPtr;
+
+ if (mPtr->declaringObjectPtr) {
+ if (oPtr == mPtr->declaringObjectPtr) {
+ callerObj = mPtr->declaringObjectPtr;
+ }
+ } else {
+ if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
+ callerCls = mPtr->declaringClassPtr;
+ }
+ }
+ }
+
+ /*
* Get the list of methods that we want to know about.
*/
- numMethodNames = TclOOGetSortedMethodList(oPtr,
+ numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
/*
@@ -573,7 +624,7 @@ TclOO_Object_Unknown(
int
TclOO_Object_LinkVar(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -675,7 +726,7 @@ TclOO_Object_LinkVar(
int
TclOO_Object_VarName(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -684,6 +735,7 @@ TclOO_Object_VarName(
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -709,6 +761,58 @@ TclOO_Object_VarName(
Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ /*
+ * Private method handling. [TIP 500]
+ *
+ * If we're in a context that can see some private methods of an
+ * object, we may need to precede a variable name with its prefix.
+ * This is a little tricky as we need to check through the inheritance
+ * hierarchy when the method was declared by a class to see if the
+ * current object is an instance of that class.
+ */
+
+ if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ CallContext *callerContext = (CallContext *)framePtr->clientData;
+ Method *mPtr = callerContext->callPtr->chain[
+ callerContext->index].mPtr;
+ PrivateVariableMapping *pvPtr;
+ int i;
+
+ if (mPtr->declaringObjectPtr == oPtr) {
+ FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
+ if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+ Tcl_GetString(argPtr))) {
+ argPtr = pvPtr->fullNameObj;
+ break;
+ }
+ }
+ } else if (mPtr->declaringClassPtr &&
+ mPtr->declaringClassPtr->privateVariables.num) {
+ Class *clsPtr = mPtr->declaringClassPtr;
+ int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
+ Class *mixinCls;
+
+ if (!isInstance) {
+ FOREACH(mixinCls, oPtr->mixins) {
+ if (TclOOIsReachable(clsPtr, mixinCls)) {
+ isInstance = 1;
+ break;
+ }
+ }
+ }
+ if (isInstance) {
+ FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
+ if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+ Tcl_GetString(argPtr))) {
+ argPtr = pvPtr->fullNameObj;
+ break;
+ }
+ }
+ }
+ }
+ }
+
varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
Tcl_AppendToObj(varNamePtr, "::", 2);
Tcl_AppendObjToObj(varNamePtr, argPtr);
@@ -729,26 +833,16 @@ TclOO_Object_VarName(
TclNewObj(varNamePtr);
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);
- }
+ Tcl_AppendToObj(varNamePtr, "(", -1);
+ Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
+ varPtr)->entry.key.objPtr);
+ Tcl_AppendToObj(varNamePtr, ")", -1);
} else {
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
}
@@ -770,7 +864,7 @@ TclOO_Object_VarName(
int
TclOONextObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -792,7 +886,7 @@ TclOONextObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
- context = framePtr->clientData;
+ context = (Tcl_ObjectContext)framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
@@ -806,7 +900,7 @@ TclOONextObjCmd(
int
TclOONextToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -832,7 +926,7 @@ TclOONextToObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
@@ -917,9 +1011,9 @@ NextRestoreFrame(
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2INT(data[2]);
}
@@ -939,7 +1033,7 @@ NextRestoreFrame(
int
TclOOSelfObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -973,7 +1067,7 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext*)framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
@@ -1054,7 +1148,7 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
- CallContext *callerPtr = framePtr->callerVarPtr->clientData;
+ CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
@@ -1155,7 +1249,7 @@ TclOOSelfObjCmd(
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
- TclNewIntObj(result[1], contextPtr->index);
+ TclNewIndexObj(result[1], contextPtr->index);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
@@ -1176,7 +1270,7 @@ TclOOSelfObjCmd(
int
TclOOCopyObjectCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 68a7173..fc36f90 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -4,7 +4,7 @@
* This file contains the method call chain management code for the
* object-system core.
*
- * Copyright (c) 2005-2012 Donal K. Fellows
+ * Copyright © 2005-2012 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,6 +15,7 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure containing a CallContext and any other values needed only during
@@ -31,6 +32,22 @@ struct ChainBuilder {
};
/*
+ * Structures used for traversing the class hierarchy to find out where
+ * definitions are supposed to be done.
+ */
+
+typedef struct {
+ Class *definerCls;
+ Tcl_Obj *namespaceName;
+} DefineEntry;
+
+typedef struct {
+ DefineEntry *list;
+ int num;
+ int size;
+} DefineChain;
+
+/*
* Extra flags used for call chain management.
*/
@@ -46,6 +63,28 @@ struct ChainBuilder {
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
/*
+ * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
+ * Itcl's special type of private.
+ */
+
+#define IS_PUBLIC(mPtr) \
+ (((mPtr)->flags & PUBLIC_METHOD) != 0)
+#define IS_UNEXPORTED(mPtr) \
+ (((mPtr)->flags & SCOPE_FLAGS) == 0)
+#define IS_ITCLPRIVATE(mPtr) \
+ (((mPtr)->flags & PRIVATE_METHOD) != 0)
+#define IS_PRIVATE(mPtr) \
+ (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
+#define WANT_PUBLIC(flags) \
+ (((flags) & PUBLIC_METHOD) != 0)
+#define WANT_UNEXPORTED(flags) \
+ (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
+#define WANT_ITCLPRIVATE(flags) \
+ (((flags) & PRIVATE_METHOD) != 0)
+#define WANT_PRIVATE(flags) \
+ (((flags) & TRUE_PRIVATE_METHOD) != 0)
+
+/*
* Function declarations for things defined in this file.
*/
@@ -55,20 +94,41 @@ static void AddClassFiltersToCallContext(Object *const oPtr,
static void AddClassMethodNames(Class *clsPtr, int flags,
Tcl_HashTable *const namesPtr,
Tcl_HashTable *const examinedClassesPtr);
+static inline void AddDefinitionNamespaceToChain(Class *const definerCls,
+ Tcl_Obj *const namespaceName,
+ DefineChain *const definePtr, int flags);
static inline void AddMethodToCallChain(Method *const mPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
Class *const filterDecl, int flags);
-static inline void AddSimpleChainToCallContext(Object *const oPtr,
+static inline int AddInstancePrivateToCallContext(Object *const oPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr, int flags);
+static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr,
+ Method *mPtr, Tcl_HashTable *namesPtr);
+static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
+ Tcl_HashTable *namesPtr);
+static inline int AddSimpleChainToCallContext(Object *const oPtr,
+ Class *const contextCls,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
-static void AddSimpleClassChainToCallContext(Class *classPtr,
+static int AddPrivatesFromClassChainToCallContext(Class *classPtr,
+ Class *const contextCls,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
+static int AddSimpleClassChainToCallContext(Class *classPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static void AddSimpleClassDefineNamespaces(Class *classPtr,
+ DefineChain *const definePtr, int flags);
+static inline void AddSimpleDefineNamespaces(Object *const oPtr,
+ DefineChain *const definePtr, int flags);
static int CmpStr(const void *ptr1, const void *ptr2);
static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc FinalizeMethodRefs;
@@ -77,6 +137,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr,
int flags, int reuseMask);
static Tcl_NRPostProc ResetFilterFlags;
static Tcl_NRPostProc SetFilterFlags;
+static int SortMethodNames(Tcl_HashTable *namesPtr, int flags,
+ const char ***stringsPtr);
static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
/*
@@ -185,11 +247,12 @@ StashCallChain(
Tcl_Obj *objPtr,
CallChain *callPtr)
{
+ Tcl_ObjInternalRep ir;
+
callPtr->refCount++;
TclGetString(objPtr);
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &methodNameType;
- objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
+ ir.twoPtrValue.ptr1 = callPtr;
+ Tcl_StoreInternalRep(objPtr, &methodNameType, &ir);
}
void
@@ -216,21 +279,16 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
-
- dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
- callPtr->refCount++;
+ StashCallChain(dstPtr,
+ (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- TclOODeleteChain(callPtr);
- objPtr->typePtr = NULL;
+ TclOODeleteChain(
+ (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
@@ -311,14 +369,18 @@ TclOOInvokeContext(
* Run the method implementation.
*/
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -330,7 +392,7 @@ SetFilterFlags(
static int
ResetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -342,7 +404,7 @@ ResetFilterFlags(
static int
FinalizeMethodRefs(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -367,6 +429,14 @@ FinalizeMethodRefs(
int
TclOOGetSortedMethodList(
Object *oPtr, /* The object to get the method names for. */
+ Object *contextObj, /* From what context object we are inquiring.
+ * NULL when the context shouldn't see
+ * object-level private methods. Note that
+ * flags can override this. */
+ Class *contextCls, /* From what context class we are inquiring.
+ * NULL when the context shouldn't see
+ * class-level private methods. Note that
+ * flags can override this. */
int flags, /* Whether we just want the public method
* names. */
const char ***stringsPtr) /* Where to write a pointer to the array of
@@ -379,12 +449,10 @@ TclOOGetSortedMethodList(
* at. Is set-like in nature and keyed by
* pointer to class. */
FOREACH_HASH_DECLS;
- int i;
+ int i, numStrings;
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
- int isWantedIn;
- void *isWanted;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -401,18 +469,13 @@ TclOOGetSortedMethodList(
if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
- int isNew;
-
- if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
+ if (IS_PRIVATE(mPtr)) {
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));
+ if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
+ continue;
}
+ AddStandardMethodName(flags, namePtr, mPtr, &names);
}
}
@@ -420,84 +483,46 @@ TclOOGetSortedMethodList(
* Process method names due to private methods on the object's class.
*/
- if (flags & PRIVATE_METHOD) {
+ if (WANT_UNEXPORTED(flags)) {
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));
- }
- }
+ if (IS_UNEXPORTED(mPtr)) {
+ AddStandardMethodName(flags, namePtr, mPtr, &names);
}
}
}
/*
+ * Process method names due to private methods on the context's object or
+ * class. Which must be correct if either are not NULL.
+ */
+
+ if (contextObj && contextObj->methodsPtr) {
+ AddPrivateMethodNames(contextObj->methodsPtr, &names);
+ }
+ if (contextCls) {
+ AddPrivateMethodNames(&contextCls->classMethods, &names);
+ }
+
+ /*
* Process (normal) method names from the class hierarchy and the mixin
* hierarchy.
*/
AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses);
FOREACH(mixinPtr, oPtr->mixins) {
- AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names,
+ AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names,
&examinedClasses);
}
- Tcl_DeleteHashTable(&examinedClasses);
-
/*
- * See how many (visible) method names there are. If none, we do not (and
- * should not) try to sort the list of them.
+ * Tidy up, sort the names and resolve finally whether we really want
+ * them (processing export layering).
*/
- 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, i, sizeof(char *), CmpStr);
- }
- *stringsPtr = strings;
- } else {
- ckfree(strings);
- }
- }
-
+ Tcl_DeleteHashTable(&examinedClasses);
+ numStrings = SortMethodNames(&names, flags, stringsPtr);
Tcl_DeleteHashTable(&names);
- return i;
+ return numStrings;
}
int
@@ -514,10 +539,7 @@ TclOOGetSortedClassMethodList(
/* Used to track what classes have been looked
* at. Is set-like in nature and keyed by
* pointer to class. */
- FOREACH_HASH_DECLS;
- int i;
- Tcl_Obj *namePtr;
- void *isWanted;
+ int numStrings;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -530,51 +552,101 @@ TclOOGetSortedClassMethodList(
Tcl_DeleteHashTable(&examinedClasses);
/*
+ * Process private method names if we should. [TIP 500]
+ */
+
+ if (WANT_PRIVATE(flags)) {
+ AddPrivateMethodNames(&clsPtr->classMethods, &names);
+ flags &= ~TRUE_PRIVATE_METHOD;
+ }
+
+ /*
+ * Tidy up, sort the names and resolve finally whether we really want
+ * them (processing export layering).
+ */
+
+ numStrings = SortMethodNames(&names, flags, stringsPtr);
+ Tcl_DeleteHashTable(&names);
+ return numStrings;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortMethodNames --
+ *
+ * Shared helper for TclOOGetSortedMethodList etc. that knows the method
+ * sorting rules.
+ *
+ * Returns:
+ * The length of the sorted list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SortMethodNames(
+ Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains
+ * whether the names are wanted and under what
+ * circumstances. */
+ int flags, /* Whether we are looking for unexported
+ * methods. Full private methods are handled
+ * on insertion to the table. */
+ const char ***stringsPtr) /* Where to store the sorted list of strings
+ * that we produce. ckalloced() */
+{
+ const char **strings;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ void *isWanted;
+ int i = 0;
+
+ /*
* 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;
+ if (namesPtr->numEntries == 0) {
+ *stringsPtr = NULL;
+ return 0;
+ }
- /*
- * 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.
- */
+ /*
+ * 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 = (const char **)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);
+ strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries);
+ FOREACH_HASH(namePtr, isWanted, namesPtr) {
+ if (!WANT_PUBLIC(flags) || (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.
- */
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names. We don't sort unless there's at least
+ * two method names.
+ */
- if (i > 0) {
- if (i > 1) {
- qsort((void *) strings, i, sizeof(char *), CmpStr);
- }
- *stringsPtr = strings;
- } else {
- ckfree(strings);
+ if (i > 0) {
+ if (i > 1) {
+ qsort((void *) strings, i, sizeof(char *), CmpStr);
}
+ *stringsPtr = strings;
+ } else {
+ ckfree(strings);
+ *stringsPtr = NULL;
}
-
- Tcl_DeleteHashTable(&names);
return i;
}
/*
- * Comparator for GetSortedMethodList
+ * Comparator for SortMethodNames
*/
static int
@@ -618,6 +690,8 @@ AddClassMethodNames(
* pointers to the classes, and the values are
* immaterial. */
{
+ int i;
+
/*
* If we've already started looking at this class, stop working on it now
* to prevent repeated work.
@@ -648,7 +722,6 @@ AddClassMethodNames(
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
- int i;
FOREACH(mixinPtr, clsPtr->mixins) {
if (mixinPtr != clsPtr) {
@@ -659,20 +732,7 @@ AddClassMethodNames(
}
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
- if (isNew) {
- int isWanted = (!(flags & PUBLIC_METHOD)
- || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
-
- isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 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));
- }
+ AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
}
if (clsPtr->superclasses.num != 1) {
@@ -682,7 +742,6 @@ AddClassMethodNames(
}
if (clsPtr->superclasses.num != 0) {
Class *superPtr;
- int i;
FOREACH(superPtr, clsPtr->superclasses) {
AddClassMethodNames(superPtr, flags, namesPtr,
@@ -694,19 +753,121 @@ AddClassMethodNames(
/*
* ----------------------------------------------------------------------
*
+ * AddPrivateMethodNames, AddStandardMethodName --
+ *
+ * Factored-out helpers for the sorted name list production functions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddPrivateMethodNames(
+ Tcl_HashTable *methodsTablePtr,
+ Tcl_HashTable *namesPtr)
+{
+ FOREACH_HASH_DECLS;
+ Method *mPtr;
+ Tcl_Obj *namePtr;
+
+ FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
+ if (IS_PRIVATE(mPtr)) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+ Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST));
+ }
+ }
+}
+
+static inline void
+AddStandardMethodName(
+ int flags,
+ Tcl_Obj *namePtr,
+ Method *mPtr,
+ Tcl_HashTable *namesPtr)
+{
+ if (!IS_PRIVATE(mPtr)) {
+ int isNew;
+ Tcl_HashEntry *hPtr =
+ Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+
+ if (isNew) {
+ int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
+ ? IN_LIST : 0;
+
+ isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 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));
+ }
+ }
+}
+
+#undef IN_LIST
+#undef NO_IMPLEMENTATION
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddInstancePrivateToCallContext --
+ *
+ * Add private methods from the instance. Called when the calling Tcl
+ * context is a TclOO method declared by an object that is the same as
+ * the current object. Returns true iff a private method was actually
+ * found and added to the call chain (as this suppresses caching).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+AddInstancePrivateToCallContext(
+ Object *const oPtr, /* Object to add call chain entries for. */
+ Tcl_Obj *const methodName, /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ int flags) /* What sort of call chain are we building. */
+{
+ Tcl_HashEntry *hPtr;
+ Method *mPtr;
+ int donePrivate = 0;
+
+ if (oPtr->methodsPtr) {
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
+ if (hPtr != NULL) {
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
+ donePrivate = 1;
+ }
+ }
+ }
+ return donePrivate;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* 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.
+ * function. Returns true if a private method was one of those found.
*
* ----------------------------------------------------------------------
*/
-static inline void
+static inline int
AddSimpleChainToCallContext(
Object *const oPtr, /* Object to add call chain entries for. */
+ Class *const contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. [TIP 500] */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
@@ -720,44 +881,62 @@ AddSimpleChainToCallContext(
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
- int i;
+ int i, foundPrivate = 0, blockedUnexported = 0;
+ Tcl_HashEntry *hPtr;
+ Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
- (char *) methodNameObj);
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
if (hPtr != NULL) {
- Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
-
- if (flags & PUBLIC_METHOD) {
- if (!(mPtr->flags & PUBLIC_METHOD)) {
- return;
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (!IS_PRIVATE(mPtr)) {
+ if (WANT_PUBLIC(flags)) {
+ if (!IS_PUBLIC(mPtr)) {
+ blockedUnexported = 1;
+ } else {
+ flags |= DEFINITE_PUBLIC;
+ }
} else {
- flags |= DEFINITE_PUBLIC;
+ flags |= DEFINITE_PROTECTED;
}
- } else {
- flags |= DEFINITE_PROTECTED;
}
}
}
if (!(flags & SPECIAL)) {
- Tcl_HashEntry *hPtr;
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
- doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ if (contextCls) {
+ foundPrivate |= AddPrivatesFromClassChainToCallContext(
+ mixinPtr, contextCls, methodNameObj, cbPtr,
+ doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ }
+ foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
+ methodNameObj, cbPtr, doneFilters,
+ flags | TRAVERSED_MIXIN, filterDecl);
}
- if (oPtr->methodsPtr) {
+ if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
- AddMethodToCallChain((Method *)Tcl_GetHashValue(hPtr), cbPtr,
- doneFilters, filterDecl, flags);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (!IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
+ }
}
}
}
- AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
+ if (contextCls) {
+ foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
+ contextCls, methodNameObj, cbPtr, doneFilters, flags,
+ filterDecl);
+ }
+ if (!blockedUnexported) {
+ foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls,
+ methodNameObj, cbPtr, doneFilters, flags, filterDecl);
+ }
+ return foundPrivate;
}
/*
@@ -820,8 +999,8 @@ AddMethodToCallChain(
* should be sufficient for [incr Tcl] support though.
*/
- if (!(callPtr->flags & PRIVATE_METHOD)
- && (mPtr->flags & PRIVATE_METHOD)
+ if (!WANT_UNEXPORTED(callPtr->flags)
+ && IS_UNEXPORTED(mPtr)
&& (mPtr->declaringClassPtr != NULL)
&& (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
return;
@@ -961,6 +1140,12 @@ TclOOGetCallContext(
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
+ Object *contextObj, /* Context object; when equal to oPtr, it
+ * means that private methods may also be
+ * added. [TIP 500] */
+ Class *contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. [TIP 500] */
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
@@ -969,7 +1154,7 @@ TclOOGetCallContext(
CallChain *callPtr;
struct ChainBuilder cb;
int i, count;
- int doFilters;
+ int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
@@ -1009,15 +1194,16 @@ TclOOGetCallContext(
* the object, and in the class).
*/
- const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+ const Tcl_ObjInternalRep *irPtr;
+ const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
- if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = (CallChain *)cacheInThisObj->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
+ callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
- FreeMethodNameRep(cacheInThisObj);
+ Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1061,10 +1247,11 @@ TclOOGetCallContext(
*/
if (flags & FORCE_UNKNOWN) {
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, 0, NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+ NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (callPtr->numChain == 0) {
@@ -1093,10 +1280,10 @@ TclOOGetCallContext(
OBJECT_MIXIN);
}
FOREACH(filterObj, oPtr->filters) {
- AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
- BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
- NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ filterObj, &cb, &doneFilters, 0, NULL);
}
AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
BUILDING_MIXINS);
@@ -1111,9 +1298,15 @@ TclOOGetCallContext(
* handle class mixins right.
*/
- AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
- flags|BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+ if (oPtr == contextObj) {
+ donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj,
+ &cb, flags);
+ donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS);
+ }
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ methodNameObj, &cb, NULL, flags, NULL);
/*
* Check to see if the method has no implementation. If so, we probably
@@ -1131,17 +1324,18 @@ TclOOGetCallContext(
TclOODeleteChain(callPtr);
return NULL;
}
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, 0, NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+ NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ 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) {
+ } else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
@@ -1247,8 +1441,7 @@ TclOOGetStereotypeCallChain(
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
- const int reuseMask =
- ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+ const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
@@ -1292,9 +1485,10 @@ TclOOGetStereotypeCallChain(
* Add the actual method implementations.
*/
- AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
+ AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
flags|BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags,
+ NULL);
/*
* Check to see if the method has no implementation. If so, we probably
@@ -1303,10 +1497,10 @@ TclOOGetStereotypeCallChain(
*/
if (count == callPtr->numChain) {
- AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
- NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
- NULL, 0, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+ &cb, NULL, BUILDING_MIXINS, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
@@ -1387,9 +1581,9 @@ AddClassFiltersToCallContext(
(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
&isNew);
if (isNew) {
- AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+ AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
- AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+ AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags, clsPtr);
}
}
@@ -1416,6 +1610,88 @@ AddClassFiltersToCallContext(
/*
* ----------------------------------------------------------------------
*
+ * AddPrivatesFromClassChainToCallContext --
+ *
+ * Helper for AddSimpleChainToCallContext that is used to find private
+ * methds and add them to the call chain. Returns true when a private
+ * method is found and added. [TIP 500]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+AddPrivatesFromClassChainToCallContext(
+ Class *classPtr, /* Class to add the call chain entries for. */
+ Class *const contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. */
+ Tcl_Obj *const methodName, /* 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) {
+ if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+ methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
+ filterDecl)) {
+ return 1;
+ }
+ }
+
+ if (classPtr == contextCls) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+ methodName);
+
+ if (hPtr != NULL) {
+ Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
+
+ if (IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
+ return 1;
+ }
+ }
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+ methodName, cbPtr, doneFilters, flags, filterDecl)) {
+ return 1;
+ }
+ }
+ /* FALLTHRU */
+ case 0:
+ return 0;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* AddSimpleClassChainToCallContext --
*
* Construct a call-chain from a class hierarchy.
@@ -1423,7 +1699,7 @@ AddClassFiltersToCallContext(
* ----------------------------------------------------------------------
*/
-static void
+static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
@@ -1439,7 +1715,7 @@ AddSimpleClassChainToCallContext(
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
- int i;
+ int i, privateDanger = 0;
Class *superPtr;
/*
@@ -1452,8 +1728,9 @@ AddSimpleClassChainToCallContext(
tailRecurse:
FOREACH(superPtr, classPtr->mixins) {
- AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
- doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+ methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
+ filterDecl);
}
if (flags & CONSTRUCTOR) {
@@ -1466,21 +1743,26 @@ AddSimpleClassChainToCallContext(
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
+ if (classPtr->flags & HAS_PRIVATE_METHODS) {
+ privateDanger |= 1;
+ }
if (hPtr != NULL) {
Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
- if (!(flags & KNOWN_STATE)) {
- if (flags & PUBLIC_METHOD) {
- if (mPtr->flags & PUBLIC_METHOD) {
+ if (!IS_PRIVATE(mPtr)) {
+ if (!(flags & KNOWN_STATE)) {
+ if (flags & PUBLIC_METHOD) {
+ if (!IS_PUBLIC(mPtr)) {
+ return privateDanger;
+ }
flags |= DEFINITE_PUBLIC;
} else {
- return;
+ flags |= DEFINITE_PROTECTED;
}
- } else {
- flags |= DEFINITE_PROTECTED;
}
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
}
- AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags);
}
}
@@ -1490,12 +1772,12 @@ AddSimpleClassChainToCallContext(
goto tailRecurse;
default:
FOREACH(superPtr, classPtr->superclasses) {
- AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
+ privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+ methodNameObj, cbPtr, doneFilters, flags, filterDecl);
}
/* FALLTHRU */
case 0:
- return;
+ return privateDanger;
}
}
@@ -1515,7 +1797,7 @@ TclOORenderCallChain(
Tcl_Interp *interp,
CallChain *callPtr)
{
- Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
+ Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
Tcl_Obj *resultObj, *descObjs[4], **objv;
Foundation *fPtr = TclOOGetFoundation(interp);
int i;
@@ -1524,12 +1806,14 @@ TclOORenderCallChain(
* Allocate the literals (potentially) used in our description.
*/
- filterLiteral = Tcl_NewStringObj("filter", -1);
+ TclNewLiteralStringObj(filterLiteral, "filter");
Tcl_IncrRefCount(filterLiteral);
- methodLiteral = Tcl_NewStringObj("method", -1);
+ TclNewLiteralStringObj(methodLiteral, "method");
Tcl_IncrRefCount(methodLiteral);
- objectLiteral = Tcl_NewStringObj("object", -1);
+ TclNewLiteralStringObj(objectLiteral, "object");
Tcl_IncrRefCount(objectLiteral);
+ TclNewLiteralStringObj(privateLiteral, "private");
+ Tcl_IncrRefCount(privateLiteral);
/*
* Do the actual construction of the descriptions. They consist of a list
@@ -1550,6 +1834,7 @@ TclOORenderCallChain(
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
+ IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
methodLiteral;
descObjs[1] =
callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
@@ -1572,6 +1857,7 @@ TclOORenderCallChain(
Tcl_DecrRefCount(filterLiteral);
Tcl_DecrRefCount(methodLiteral);
Tcl_DecrRefCount(objectLiteral);
+ Tcl_DecrRefCount(privateLiteral);
/*
* Finish building the description and return it.
@@ -1583,6 +1869,246 @@ TclOORenderCallChain(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineContextNamespace --
+ *
+ * Responsible for determining which namespace to use for definitions.
+ * This is done by building a define chain, which models (strongly!) the
+ * way that a call chain works but with a different internal model.
+ *
+ * Then it walks the chain to find the first namespace name that actually
+ * resolves to an existing namespace.
+ *
+ * Returns:
+ * Name of namespace, or NULL if none can be found. Note that this
+ * function does *not* set an error message in the interpreter on failure.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */
+
+Tcl_Namespace *
+TclOOGetDefineContextNamespace(
+ Tcl_Interp *interp, /* In what interpreter should namespace names
+ * actually be resolved. */
+ Object *oPtr, /* The object to get the context for. */
+ int forClass) /* What sort of context are we looking for.
+ * If true, we are going to use this for
+ * [oo::define], otherwise, we are going to
+ * use this for [oo::objdefine]. */
+{
+ DefineChain define;
+ DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
+ DefineEntry *entryPtr;
+ Tcl_Namespace *nsPtr = NULL;
+ int i;
+
+ define.list = staticSpace;
+ define.num = 0;
+ define.size = DEFINE_CHAIN_STATIC_SIZE;
+
+ /*
+ * Add the actual define locations. We have to do this twice to handle
+ * class mixins right.
+ */
+
+ AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
+ AddSimpleDefineNamespaces(oPtr, &define, forClass);
+
+ /*
+ * Go through the list until we find a namespace whose name we can
+ * resolve.
+ */
+
+ FOREACH_STRUCT(entryPtr, define) {
+ if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
+ &nsPtr) == TCL_OK) {
+ break;
+ }
+ Tcl_ResetResult(interp);
+ }
+ if (define.list != staticSpace) {
+ ckfree(define.list);
+ }
+ return nsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by an
+ * object's class and its mixins, taking into account everything they
+ * inherit from.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddSimpleDefineNamespaces(
+ Object *const oPtr, /* Object to add define chain entries for. */
+ DefineChain *const definePtr,
+ /* Where to add the define chain entries. */
+ int flags) /* What sort of define chain are we
+ * building. */
+{
+ Class *mixinPtr;
+ int i;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by a class
+ * and its superclasses and its class mixins.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassDefineNamespaces(
+ Class *classPtr, /* Class to add the define chain entries for. */
+ DefineChain *const definePtr,
+ /* Where to add the define chain entries. */
+ int flags) /* What sort of define chain are we
+ * building. */
+{
+ 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.
+ */
+
+ tailRecurse:
+ FOREACH(superPtr, classPtr->mixins) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
+ definePtr, flags);
+ } else {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
+ definePtr, flags);
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr, flags);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddDefinitionNamespaceToChain --
+ *
+ * Adds a single item to the definition chain (if it is meaningful),
+ * reallocating the space for the chain if necessary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddDefinitionNamespaceToChain(
+ Class *const definerCls, /* What class defines this entry. */
+ Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a
+ * no-op). */
+ DefineChain *const definePtr,
+ /* The define chain to add the method
+ * implementation to. */
+ int flags) /* Used to check if we're mixin-consistent
+ * only. Mixin-consistent means that either
+ * we're looking to add things from a mixin
+ * and we have passed a mixin, or we're not
+ * looking to add things from a mixin and have
+ * not passed a mixin. */
+{
+ int i;
+
+ /*
+ * Return if this entry is blank. This is also where we enforce
+ * mixin-consistency.
+ */
+
+ if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain.
+ */
+
+ for (i=0 ; i<definePtr->num ; i++) {
+ if (definePtr->list[i].definerCls == definerCls) {
+ /*
+ * 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 invocations in the call chain; it just rearranges them.
+ *
+ * We skip changing anything if the place we found was already at
+ * the end of the list.
+ */
+
+ if (i < definePtr->num - 1) {
+ memmove(&definePtr->list[i], &definePtr->list[i + 1],
+ sizeof(DefineEntry) * (definePtr->num - i - 1));
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ }
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the define. 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 (definePtr->num == definePtr->size) {
+ definePtr->size *= 2;
+ if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
+ DefineEntry *staticList = definePtr->list;
+
+ definePtr->list =
+ (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size);
+ memcpy(definePtr->list, staticList,
+ sizeof(DefineEntry) * definePtr->num);
+ } else {
+ definePtr->list = (DefineEntry *)ckrealloc(definePtr->list,
+ sizeof(DefineEntry) * definePtr->size);
+ }
+ }
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ definePtr->num++;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 647bbd5..13e07ec 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -59,11 +59,11 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method);
/* 11 */
TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
- int isPublic, const Tcl_MethodType *typePtr,
+ int flags, const Tcl_MethodType *typePtr,
void *clientData);
/* 12 */
TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
- Tcl_Obj *nameObj, int isPublic,
+ Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
/* 13 */
@@ -116,13 +116,27 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp,
/* 28 */
TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
Tcl_Object object);
-/* Slot 29 is reserved */
-/* Slot 30 is reserved */
-/* Slot 31 is reserved */
-/* Slot 32 is reserved */
-/* Slot 33 is reserved */
+/* 29 */
+TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method);
+/* 30 */
+TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object);
+/* 31 */
+TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp,
+ Tcl_Object object);
+/* 32 */
+TCLAPI int Tcl_MethodIsType2(Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr);
+/* 33 */
+TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData);
/* 34 */
-TCLAPI void TclOOUnusedStubEntry(void);
+TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType2 *typePtr,
+ void *clientData);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
@@ -143,8 +157,8 @@ typedef struct TclOOStubs {
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **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, void *clientData); /* 11 */
- Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 12 */
+ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */
+ Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *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 */
@@ -161,12 +175,12 @@ typedef struct TclOOStubs {
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 */
- void (*reserved29)(void);
- void (*reserved30)(void);
- void (*reserved31)(void);
- void (*reserved32)(void);
- void (*reserved33)(void);
- void (*tclOOUnusedStubEntry) (void); /* 34 */
+ int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
+ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
+ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
+ int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */
+ Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */
+ Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
@@ -239,18 +253,21 @@ extern const TclOOStubs *tclOOStubsPtr;
(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
#define Tcl_GetObjectName \
(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
-/* Slot 29 is reserved */
-/* Slot 30 is reserved */
-/* Slot 31 is reserved */
-/* Slot 32 is reserved */
-/* Slot 33 is reserved */
-#define TclOOUnusedStubEntry \
- (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */
+#define Tcl_MethodIsPrivate \
+ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
+#define Tcl_GetClassOfObject \
+ (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
+#define Tcl_GetObjectClassName \
+ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
+#define Tcl_MethodIsType2 \
+ (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */
+#define Tcl_NewInstanceMethod2 \
+ (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */
+#define Tcl_NewMethod2 \
+ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */
#endif /* defined(USE_TCLOO_STUBS) */
/* !END!: Do not edit above this line. */
-#undef TclOOUnusedStubEntry
-
#endif /* _TCLOODECLS */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 4b97740..686fd00 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
- * Copyright (c) 2006-2013 by Donal K. Fellows
+ * Copyright © 2006-2013 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,12 @@
#include "tclOOInt.h"
/*
+ * The actual value used to mark private declaration frames.
+ */
+
+#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)
+
+/*
* The maximum length of fully-qualified object name to use in an errorinfo
* message. Longer than this will be curtailed.
*/
@@ -31,14 +37,17 @@ struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
+ const Tcl_MethodType resolverType;
};
-#define SLOT(name,getter,setter) \
+#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
- setter, NULL, NULL}}
+ setter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+ resolver, NULL, NULL}}
/*
* A [string match] pattern used to determine if a method should be exported.
@@ -60,6 +69,8 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
+static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp,
+ Tcl_Obj *namespaceName);
static inline int InitDefineContext(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr, Object *oPtr,
int objc, Tcl_Obj *const objv[]);
@@ -109,26 +120,59 @@ static int ObjVarsGet(ClientData clientData,
static int ObjVarsSet(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static int ResolveClass(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
/*
* Now define the slots used in declarations.
*/
static const struct DeclaredSlot slots[] = {
- SLOT("define::filter", ClassFilterGet, ClassFilterSet),
- SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
- SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
- SLOT("define::variable", ClassVarsGet, ClassVarsSet),
- SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
- SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
- SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
- {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+ {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
+
+/*
+ * How to build the in-namespace name of a private variable. This is a pattern
+ * used with Tcl_ObjPrintf().
+ */
+
+#define PRIVATE_VARIABLE_PATTERN "%d : %s"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsPrivateDefine --
+ *
+ * Extracts whether the current context is handling private definitions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsPrivateDefine(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (!iPtr->varFramePtr) {
+ return 0;
+ }
+ return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
+}
/*
* ----------------------------------------------------------------------
*
* 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
@@ -173,6 +217,7 @@ BumpGlobalEpoch(
* ----------------------------------------------------------------------
*
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -195,6 +240,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -234,9 +280,9 @@ TclOOObjectSetFilters(
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
- filtersList = ckalloc(size);
+ filtersList = (Tcl_Obj **)ckalloc(size);
} else {
- filtersList = ckrealloc(oPtr->filters.list, size);
+ filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -253,6 +299,7 @@ TclOOObjectSetFilters(
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -292,9 +339,9 @@ TclOOClassSetFilters(
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
- filtersList = ckalloc(size);
+ filtersList = (Tcl_Obj **)ckalloc(size);
} else {
- filtersList = ckrealloc(classPtr->filters.list, size);
+ filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -315,6 +362,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -347,10 +395,10 @@ TclOOObjectSetMixins(
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
- oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
+ oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
- oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
@@ -374,6 +422,7 @@ TclOOObjectSetMixins(
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -404,10 +453,10 @@ TclOOClassSetMixins(
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
- classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
+ classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
- classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
@@ -427,7 +476,125 @@ TclOOClassSetMixins(
/*
* ----------------------------------------------------------------------
*
+ * InstallStandardVariableMapping, InstallPrivateVariableMapping --
+ *
+ * Helpers for installing standard and private variable maps.
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline void
+InstallStandardVariableMapping(
+ VariableNameList *vnlPtr,
+ int varc,
+ Tcl_Obj *const *varv)
+{
+ Tcl_Obj *variableObj;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, *vnlPtr) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(vnlPtr->list);
+ } else if (i) {
+ vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
+ } else {
+ vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc);
+ }
+ }
+ vnlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ vnlPtr->list[n++] = varv[i];
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ vnlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static inline void
+InstallPrivateVariableMapping(
+ PrivateVariableList *pvlPtr,
+ int varc,
+ Tcl_Obj *const *varv,
+ int creationEpoch)
+{
+ PrivateVariableMapping *privatePtr;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH_STRUCT(privatePtr, *pvlPtr) {
+ Tcl_DecrRefCount(privatePtr->variableObj);
+ Tcl_DecrRefCount(privatePtr->fullNameObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(pvlPtr->list);
+ } else if (i) {
+ pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * varc);
+ } else {
+ pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc);
+ }
+ }
+
+ pvlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ privatePtr = &(pvlPtr->list[n++]);
+ privatePtr->variableObj = varv[i];
+ privatePtr->fullNameObj = Tcl_ObjPrintf(
+ PRIVATE_VARIABLE_PATTERN,
+ creationEpoch, Tcl_GetString(varv[i]));
+ Tcl_IncrRefCount(privatePtr->fullNameObj);
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ pvlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RenameDeleteMethod --
+ *
* Core of the code to rename and delete methods.
*
* ----------------------------------------------------------------------
@@ -497,7 +664,7 @@ RenameDeleteMethod(
* Complete the splicing by changing the method's name.
*/
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (toPtr) {
Tcl_IncrRefCount(toPtr);
Tcl_DecrRefCount(mPtr->namePtr);
@@ -517,6 +684,7 @@ RenameDeleteMethod(
* ----------------------------------------------------------------------
*
* 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
@@ -527,7 +695,7 @@ RenameDeleteMethod(
int
TclOOUnknownDefinition(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -548,13 +716,13 @@ TclOOUnknownDefinition(
return TCL_ERROR;
}
- soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
+ soughtStr = TclGetStringFromObj(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);
+ const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
@@ -570,7 +738,7 @@ TclOOUnknownDefinition(
* Got one match, and only one match!
*/
- Tcl_Obj **newObjv =
+ Tcl_Obj **newObjv = (Tcl_Obj **)
TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
@@ -596,6 +764,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -609,7 +778,7 @@ FindCommand(
Tcl_Namespace *const namespacePtr)
{
int length;
- const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
+ const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
@@ -656,6 +825,7 @@ FindCommand(
* ----------------------------------------------------------------------
*
* 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.
@@ -675,8 +845,7 @@ InitDefineContext(
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot process definitions; support namespace deleted",
- -1));
+ "no definition namespace available", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -698,6 +867,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -712,14 +882,15 @@ TclOOGetDefineCmdContext(
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
- || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
+ && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
- object = iPtr->varFramePtr->clientData;
+ object = (Tcl_Object)iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
@@ -733,11 +904,12 @@ TclOOGetDefineCmdContext(
/*
* ----------------------------------------------------------------------
*
- * 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.
+ * GetClassInOuterContext, GetNamespaceInOuterContext --
+ *
+ * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj 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.
*
* ----------------------------------------------------------------------
*/
@@ -752,7 +924,8 @@ GetClassInOuterContext(
Object *oPtr;
CallFrame *savedFramePtr = iPtr->varFramePtr;
- while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
if (iPtr->varFramePtr->callerVarPtr == NULL) {
Tcl_Panic("getting outer context when already in global context");
}
@@ -771,11 +944,37 @@ GetClassInOuterContext(
}
return oPtr->classPtr;
}
+
+static inline Tcl_Namespace *
+GetNamespaceInOuterContext(
+ Tcl_Interp *interp,
+ Tcl_Obj *namespaceName)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Namespace *nsPtr;
+ int result;
+ CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
+ if (iPtr->varFramePtr->callerVarPtr == NULL) {
+ Tcl_Panic("getting outer context when already in global context");
+ }
+ iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+ }
+ result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return nsPtr;
+}
/*
* ----------------------------------------------------------------------
*
* GenerateErrorInfo --
+ *
* Factored out code to generate part of the error trace messages.
*
* ----------------------------------------------------------------------
@@ -800,7 +999,7 @@ GenerateErrorInfo(
int length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
- const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
+ const char *objName = TclGetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
@@ -814,6 +1013,7 @@ GenerateErrorInfo(
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
+ *
* Part of the implementation of the "oo::define" and "oo::objdefine"
* commands that is used to implement the more-than-one-argument case,
* applying ensemble-like tricks with dispatch so that error messages are
@@ -865,7 +1065,7 @@ MagicDefinitionInvoke(
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
- TclListObjGetElements(NULL, objPtr, &dummy, &objs);
+ TclListObjGetElementsM(NULL, objPtr, &dummy, &objs);
result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
@@ -880,6 +1080,7 @@ MagicDefinitionInvoke(
* ----------------------------------------------------------------------
*
* 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
@@ -891,12 +1092,12 @@ MagicDefinitionInvoke(
int
TclOODefineObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -911,7 +1112,7 @@ TclOODefineObjCmd(
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s does not refer to a class",TclGetString(objv[1])));
+ "%s does not refer to a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -922,7 +1123,8 @@ TclOODefineObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -938,7 +1140,7 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -954,6 +1156,7 @@ TclOODefineObjCmd(
* ----------------------------------------------------------------------
*
* 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
@@ -965,12 +1168,12 @@ TclOODefineObjCmd(
int
TclOOObjDefObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -989,7 +1192,8 @@ TclOOObjDefObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1005,7 +1209,7 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1021,6 +1225,7 @@ TclOOObjDefObjCmd(
* ----------------------------------------------------------------------
*
* 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
@@ -1032,33 +1237,39 @@ TclOOObjDefObjCmd(
int
TclOODefineSelfObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
- int result;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
+ int result, isPrivate;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
+ if (objc < 2) {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+ }
+
+ isPrivate = IsPrivateDefine(interp);
+
/*
* Make the oo::objdefine namespace the current namespace and evaluate the
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
+ if (isPrivate) {
+ ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+ }
AddRef(oPtr);
if (objc == 2) {
@@ -1066,13 +1277,13 @@ TclOODefineSelfObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
- ((Interp *)interp)->cmdFramePtr, 2);
+ ((Interp *)interp)->cmdFramePtr, 1);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1087,7 +1298,115 @@ TclOODefineSelfObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineObjSelfObjCmd --
+ *
+ * Implementation of the "self" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjSelfObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefinePrivateObjCmd --
+ *
+ * Implementation of the "private" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefinePrivateObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstancePrivate = (clientData != NULL);
+ /* Just so that we can generate the correct
+ * error message depending on the context of
+ * usage of this function. */
+ Interp *iPtr = (Interp *) interp;
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int saved; /* The saved flag. We restore it on exit so
+ * that [private private ...] doesn't make
+ * things go weird. */
+ int result;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
+ return TCL_OK;
+ }
+
+ /*
+ * Change the frame type flag while evaluating the body.
+ */
+
+ saved = iPtr->varFramePtr->isProcCallFrame;
+ iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+
+ /*
+ * Evaluate the body; standard pattern.
+ */
+
+ AddRef(oPtr);
+ if (objc == 2) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
+ result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+ if (result == TCL_ERROR) {
+ GenerateErrorInfo(interp, oPtr, objNameObj,
+ isInstancePrivate ? "object" : "class");
+ }
+ TclDecrRefCount(objNameObj);
+ } else {
+ result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
+ 1, objc, objv);
+ }
+ TclOODecrRefCount(oPtr);
+
+ /*
+ * Restore the frame type flag to what it was previously.
+ */
+
+ iPtr->varFramePtr->isProcCallFrame = saved;
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineClassObjCmd --
+ *
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
@@ -1096,7 +1415,7 @@ TclOODefineSelfObjCmd(
int
TclOODefineClassObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1196,6 +1515,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1204,7 +1524,7 @@ TclOODefineClassObjCmd(
int
TclOODefineConstructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1230,7 +1550,7 @@ TclOODefineConstructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[2], &bodyLength);
+ TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1263,7 +1583,93 @@ TclOODefineConstructorObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineDefnNsObjCmd --
+ *
+ * Implementation of the "definitionnamespace" subcommand of the
+ * "oo::define" command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDefnNsObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Object *oPtr;
+ Tcl_Namespace *nsPtr;
+ Tcl_Obj *nsNamePtr, **storagePtr;
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the definition namespace of the root classes",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the arguments and work out what the user wants to do.
+ */
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_GetString(objv[objc - 1])[0]) {
+ nsNamePtr = NULL;
+ } else {
+ nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
+ if (nsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ Tcl_IncrRefCount(nsNamePtr);
+ }
+
+ /*
+ * Update the correct field of the class definition.
+ */
+
+ if (kind) {
+ storagePtr = &oPtr->classPtr->objDefinitionNs;
+ } else {
+ storagePtr = &oPtr->classPtr->clsDefinitionNs;
+ }
+ if (*storagePtr != NULL) {
+ Tcl_DecrRefCount(*storagePtr);
+ }
+ *storagePtr = nsNamePtr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineDeleteMethodObjCmd --
+ *
* Implementation of the "deletemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1320,6 +1726,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1328,7 +1735,7 @@ TclOODefineDeleteMethodObjCmd(
int
TclOODefineDestructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1349,7 +1756,7 @@ TclOODefineDestructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[1], &bodyLength);
+ TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1384,6 +1791,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1433,7 +1841,7 @@ TclOODefineExportObjCmd(
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -1445,17 +1853,18 @@ TclOODefineExportObjCmd(
}
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)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);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
- if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+ if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
+ mPtr->flags &= ~TRUE_PRIVATE_METHOD;
changed = 1;
}
}
@@ -1478,6 +1887,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1514,6 +1924,9 @@ TclOODefineForwardObjCmd(
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
/*
* Create the method structure.
@@ -1538,6 +1951,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1551,12 +1965,28 @@ TclOODefineMethodObjCmd(
int objc,
Tcl_Obj *const *objv)
{
+ /*
+ * Table of export modes for methods and their corresponding enum.
+ */
+
+ static const char *const exportModes[] = {
+ "-export",
+ "-private",
+ "-unexport",
+ NULL
+ };
+ enum ExportMode {
+ MODE_EXPORT,
+ MODE_PRIVATE,
+ MODE_UNEXPORT
+ } exportMode;
+
int isInstanceMethod = (clientData != NULL);
Object *oPtr;
- int isPublic;
+ int isPublic = 0;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body");
return TCL_ERROR;
}
@@ -1570,8 +2000,30 @@ TclOODefineMethodObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
- ? PUBLIC_METHOD : 0;
+ if (objc == 5) {
+ if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
+ 0, &exportMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (exportMode) {
+ case MODE_EXPORT:
+ isPublic = PUBLIC_METHOD;
+ break;
+ case MODE_PRIVATE:
+ isPublic = TRUE_PRIVATE_METHOD;
+ break;
+ case MODE_UNEXPORT:
+ isPublic = 0;
+ break;
+ }
+ } else {
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ } else {
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
+ ? PUBLIC_METHOD : 0;
+ }
+ }
/*
* Create the method by using the right back-end API.
@@ -1579,12 +2031,12 @@ TclOODefineMethodObjCmd(
if (isInstanceMethod) {
if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
} else {
if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
}
@@ -1595,6 +2047,7 @@ TclOODefineMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1651,6 +2104,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1700,7 +2154,7 @@ TclOODefineUnexportObjCmd(
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -1712,17 +2166,17 @@ TclOODefineUnexportObjCmd(
}
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)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);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
- if (isNew || mPtr->flags & PUBLIC_METHOD) {
- mPtr->flags &= ~PUBLIC_METHOD;
+ if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+ mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
changed = 1;
}
}
@@ -1745,6 +2199,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1799,6 +2254,7 @@ Tcl_ClassSetDestructor(
* ----------------------------------------------------------------------
*
* TclOODefineSlots --
+ *
* Create the "::oo::Slot" class and its standard instances. Class
* definition is empty at the stage (added by scripting).
*
@@ -1812,6 +2268,7 @@ TclOODefineSlots(
const struct DeclaredSlot *slotInfoPtr;
Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
Class *slotCls;
slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
@@ -1821,6 +2278,7 @@ TclOODefineSlots(
}
Tcl_IncrRefCount(getName);
Tcl_IncrRefCount(setName);
+ Tcl_IncrRefCount(resolveName);
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
(Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
@@ -1828,13 +2286,18 @@ TclOODefineSlots(
if (slotObject == NULL) {
continue;
}
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -1842,6 +2305,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1850,7 +2314,7 @@ TclOODefineSlots(
static int
ClassFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1884,7 +2348,7 @@ ClassFilterGet(
static int
ClassFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1908,7 +2372,7 @@ ClassFilterSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &filterc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1921,6 +2385,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -1929,7 +2394,7 @@ ClassFilterSet(
static int
ClassMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1966,7 +2431,7 @@ ClassMixinGet(
static int
ClassMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1991,12 +2456,12 @@ ClassMixinSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &mixinc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2026,6 +2491,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2034,7 +2500,7 @@ ClassMixinSet(
static int
ClassSuperGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2070,7 +2536,7 @@ ClassSuperGet(
static int
ClassSuperSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2100,7 +2566,7 @@ ClassSuperSet(
"may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &superc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &superc,
&superv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2119,7 +2585,7 @@ ClassSuperSet(
*/
if (superc == 0) {
- superclasses = ckrealloc(superclasses, sizeof(Class *));
+ superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *));
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
} else {
@@ -2176,7 +2642,7 @@ ClassSuperSet(
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
- ckfree((char *) oPtr->classPtr->superclasses.list);
+ ckfree(oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
oPtr->classPtr->superclasses.num = superc;
@@ -2192,6 +2658,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2200,14 +2667,14 @@ ClassSuperSet(
static int
ClassVarsGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2225,8 +2692,18 @@ ClassVarsGet(
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2234,7 +2711,7 @@ ClassVarsGet(
static int
ClassVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2242,7 +2719,7 @@ ClassVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
int i;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
@@ -2259,13 +2736,13 @@ ClassVarsSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &varc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2283,49 +2760,11 @@ ClassVarsSet(
}
}
- for (i = 0; i < varc; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree((char *) oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
- }
-
- oPtr->classPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
-
- Tcl_InitObjHashTable(&uniqueTable);
- for (i = n = 0; i < varc; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->classPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->classPtr->variables.num = n;
-
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
-
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
+ varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
}
return TCL_OK;
}
@@ -2334,6 +2773,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2342,7 +2782,7 @@ ClassVarsSet(
static int
ObjFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2370,7 +2810,7 @@ ObjFilterGet(
static int
ObjFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2388,7 +2828,7 @@ ObjFilterSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &filterc,
+ if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2401,6 +2841,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2409,7 +2850,7 @@ ObjFilterSet(
static int
ObjMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2441,7 +2882,7 @@ ObjMixinGet(
static int
ObjMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2461,12 +2902,12 @@ ObjMixinSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &mixinc,
+ if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2486,6 +2927,7 @@ ObjMixinSet(
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
@@ -2494,14 +2936,14 @@ ObjMixinSet(
static int
ObjVarsGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2513,8 +2955,18 @@ ObjVarsGet(
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2522,7 +2974,7 @@ ObjVarsGet(
static int
ObjVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2530,7 +2982,7 @@ ObjVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2540,13 +2992,13 @@ ObjVarsSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &varc,
+ if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2563,50 +3015,66 @@ ObjVarsSet(
return TCL_ERROR;
}
}
- for (i = 0; i < varc; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree((char *) oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
+ oPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->variables, varc, varv);
}
- oPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ResolveClass --
+ *
+ * Implementation of the "Resolve" support method for some slots (those
+ * that are slots around a list of classes). This resolves possible class
+ * names to their fully-qualified names if possible.
+ *
+ * ----------------------------------------------------------------------
+ */
- Tcl_InitObjHashTable(&uniqueTable);
- for (i = n = 0; i < varc; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->variables.num = n;
+static int
+ResolveClass(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int idx = Tcl_ObjectContextSkippedArgs(context);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr;
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
+ /*
+ * Check if were called wrongly. The definition context isn't used...
+ * except that GetClassInOuterContext() assumes that it is there.
+ */
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != idx + 1) {
+ Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
+ return TCL_ERROR;
}
+
+ /*
+ * Resolve the class if possible. If not, remove any resolution error and
+ * return what we've got anyway as the failure might not be fatal overall.
+ */
+
+ clsPtr = GetClassInOuterContext(interp, objv[idx],
+ "USER SHOULD NOT SEE THIS MESSAGE");
+ if (clsPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, objv[idx]);
+ } else {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
+ }
+
return TCL_OK;
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 9f1233c..4e5b55b 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo-related [info]
* subcommands.
*
- * Copyright (c) 2006-2011 by Donal K. Fellows
+ * Copyright © 2006-2011 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIdCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
@@ -32,6 +33,7 @@ static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
@@ -50,6 +52,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
static const EnsembleImplMap infoObjectCmds[] = {
{"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+ {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -58,7 +61,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
- {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -71,6 +74,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -80,7 +84,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -167,7 +171,7 @@ GetClassFromObj(
static int
InfoObjectClassCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -202,11 +206,11 @@ InfoObjectClassCmd(
continue;
}
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
return TCL_OK;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
return TCL_OK;
}
@@ -224,7 +228,7 @@ InfoObjectClassCmd(
static int
InfoObjectDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -257,7 +261,7 @@ InfoObjectDefnCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
@@ -281,7 +285,7 @@ InfoObjectDefnCmd(
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -298,7 +302,7 @@ InfoObjectDefnCmd(
static int
InfoObjectFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -337,7 +341,7 @@ InfoObjectFiltersCmd(
static int
InfoObjectForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -368,7 +372,7 @@ InfoObjectForwardCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
@@ -394,7 +398,7 @@ InfoObjectForwardCmd(
static int
InfoObjectIsACmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -513,21 +517,28 @@ InfoObjectIsACmd(
static int
InfoObjectMethodsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
- int flag = PUBLIC_METHOD, recurse = 0;
+ int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
static const char *const options[] = {
- "-all", "-localprivate", "-private", NULL
+ "-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
- OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+ };
+ static const char *const scopes[] = {
+ "private", "public", "unexported"
+ };
+ enum Scopes {
+ SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
+ SCOPE_LOCALPRIVATE
};
if (objc < 2) {
@@ -556,14 +567,45 @@ InfoObjectMethodsCmd(
case OPT_PRIVATE:
flag = 0;
break;
+ case OPT_SCOPE:
+ if (++i >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing option for -scope"));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+ &scope) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
}
}
}
+ if (scope != -1) {
+ recurse = 0;
+ switch (scope) {
+ case SCOPE_PRIVATE:
+ flag = TRUE_PRIVATE_METHOD;
+ break;
+ case SCOPE_PUBLIC:
+ flag = PUBLIC_METHOD;
+ break;
+ case SCOPE_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case SCOPE_UNEXPORTED:
+ flag = 0;
+ break;
+ }
+ }
TclNewObj(resultObj);
if (recurse) {
const char **names;
- int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+ int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
+ &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -574,7 +616,7 @@ InfoObjectMethodsCmd(
}
} else if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
@@ -595,7 +637,7 @@ InfoObjectMethodsCmd(
static int
InfoObjectMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -626,7 +668,7 @@ InfoObjectMethodTypeCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -652,7 +694,7 @@ InfoObjectMethodTypeCmd(
static int
InfoObjectMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -686,6 +728,38 @@ InfoObjectMixinsCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoObjectIdCmd --
+ *
+ * Implements [info object creationid $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIdCmd(
+ TCL_UNUSED(void *),
+ 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_NewWideIntObj(oPtr->creationEpoch));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
@@ -695,7 +769,7 @@ InfoObjectMixinsCmd(
static int
InfoObjectNsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -721,34 +795,50 @@ InfoObjectNsCmd(
*
* InfoObjectVariablesCmd --
*
- * Implements [info object variables $objName]
+ * Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
- Tcl_Obj *variableObj, *resultObj;
- int i;
+ Tcl_Obj *resultObj;
+ int i, isPrivate = 0;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
+ if (objc == 3) {
+ if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+ return TCL_ERROR;
+ }
+ isPrivate = 1;
+ }
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (isPrivate) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -766,7 +856,7 @@ InfoObjectVariablesCmd(
static int
InfoObjectVarsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -827,7 +917,7 @@ InfoObjectVarsCmd(
static int
InfoClassConstrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -888,7 +978,7 @@ InfoClassConstrCmd(
static int
InfoClassDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -915,7 +1005,7 @@ InfoClassDefnCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
@@ -939,7 +1029,7 @@ InfoClassDefnCmd(
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -947,6 +1037,56 @@ InfoClassDefnCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoClassDefnNsCmd --
+ *
+ * Implements [info class definitionnamespace $clsName ?$kind?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnNsCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Tcl_Obj *nsNamePtr;
+ Class *clsPtr;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (kind) {
+ nsNamePtr = clsPtr->objDefinitionNs;
+ } else {
+ nsNamePtr = clsPtr->clsDefinitionNs;
+ }
+ if (nsNamePtr) {
+ Tcl_SetObjResult(interp, nsNamePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoClassDestrCmd --
*
* Implements [info class destructor $clsName]
@@ -956,7 +1096,7 @@ InfoClassDefnCmd(
static int
InfoClassDestrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1000,7 +1140,7 @@ InfoClassDestrCmd(
static int
InfoClassFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1038,7 +1178,7 @@ InfoClassFiltersCmd(
static int
InfoClassForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1063,7 +1203,7 @@ InfoClassForwardCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
@@ -1089,7 +1229,7 @@ InfoClassForwardCmd(
static int
InfoClassInstancesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1130,27 +1270,33 @@ InfoClassInstancesCmd(
*
* InfoClassMethodsCmd --
*
- * Implements [info class methods $clsName ?-private?]
+ * Implements [info class methods $clsName ?options...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- int flag = PUBLIC_METHOD, recurse = 0;
+ int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
Class *clsPtr;
static const char *const options[] = {
- "-all", "-localprivate", "-private", NULL
+ "-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
- OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+ };
+ static const char *const scopes[] = {
+ "private", "public", "unexported"
+ };
+ enum Scopes {
+ SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
};
if (objc < 2) {
@@ -1179,9 +1325,36 @@ InfoClassMethodsCmd(
case OPT_PRIVATE:
flag = 0;
break;
+ case OPT_SCOPE:
+ if (++i >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing option for -scope"));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+ &scope) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
}
}
}
+ if (scope != -1) {
+ recurse = 0;
+ switch (scope) {
+ case SCOPE_PRIVATE:
+ flag = TRUE_PRIVATE_METHOD;
+ break;
+ case SCOPE_PUBLIC:
+ flag = PUBLIC_METHOD;
+ break;
+ case SCOPE_UNEXPORTED:
+ flag = 0;
+ break;
+ }
+ }
TclNewObj(resultObj);
if (recurse) {
@@ -1199,7 +1372,7 @@ InfoClassMethodsCmd(
FOREACH_HASH_DECLS;
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
@@ -1220,7 +1393,7 @@ InfoClassMethodsCmd(
static int
InfoClassMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1247,7 +1420,7 @@ InfoClassMethodTypeCmd(
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -1272,7 +1445,7 @@ InfoClassMethodTypeCmd(
static int
InfoClassMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1314,7 +1487,7 @@ InfoClassMixinsCmd(
static int
InfoClassSubsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1369,7 +1542,7 @@ InfoClassSubsCmd(
static int
InfoClassSupersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1401,34 +1574,50 @@ InfoClassSupersCmd(
*
* InfoClassVariablesCmd --
*
- * Implements [info class variables $clsName]
+ * Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
- Tcl_Obj *variableObj, *resultObj;
- int i;
+ Tcl_Obj *resultObj;
+ int i, isPrivate = 0;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className");
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
+ if (objc == 3) {
+ if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+ return TCL_ERROR;
+ }
+ isPrivate = 1;
+ }
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
- FOREACH(variableObj, clsPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (isPrivate) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -1446,7 +1635,7 @@ InfoClassVariablesCmd(
static int
InfoObjectCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1467,7 +1656,8 @@ InfoObjectCallCmd(
* Get the call context and render its call chain.
*/
- contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
+ NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
@@ -1491,7 +1681,7 @@ InfoObjectCallCmd(
static int
InfoClassCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 2931044..725c4ce 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -125,6 +125,18 @@ typedef struct ForwardMethod {
} ForwardMethod;
/*
+ * Structure used in private variable mappings. Describes the mapping of a
+ * single variable from the user's local name to the system's storage name.
+ * [TIP #500]
+ */
+
+typedef struct {
+ Tcl_Obj *variableObj; /* Name used within methods. This is the part
+ * that is properly under user control. */
+ Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */
+} PrivateVariableMapping;
+
+/*
* 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
@@ -142,6 +154,13 @@ typedef struct ForwardMethod {
struct { int num, size; listType_t *list; }
/*
+ * These types are needed in function arguments.
+ */
+
+typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
+typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
+
+/*
* Now, the definition of what an object actually is.
*/
@@ -186,7 +205,12 @@ typedef struct Object {
Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
- LIST_STATIC(Tcl_Obj *) variables;
+ VariableNameList variables;
+ PrivateVariableList privateVariables;
+ /* Configurations for the variable resolver
+ * used inside methods. */
+ Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
+ * command. */
} Object;
#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
@@ -211,7 +235,14 @@ typedef struct Object {
* other spots). */
#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
* unknown method handler at that point. */
-#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. */
+#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. Used
+ * during fundamental object type mutation to
+ * make sure that the object actually survives
+ * to the end of the operation. */
+#define HAS_PRIVATE_METHODS 0x40000
+ /* Object/class has (or had) private methods,
+ * and so shouldn't be cached so
+ * aggressively. */
/*
* And the definition of a class. Note that every class also has an associated
@@ -266,7 +297,28 @@ typedef struct Class {
* object doesn't override with its own mixins
* (and filters and method implementations for
* when getting method chains). */
- LIST_STATIC(Tcl_Obj *) variables;
+ VariableNameList variables;
+ PrivateVariableList privateVariables;
+ /* Configurations for the variable resolver
+ * used inside methods. */
+ Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as classes. If NULL, use the value from the
+ * class hierarchy. It's an error at
+ * [oo::define] call time if this namespace is
+ * defined but doesn't exist; we also check at
+ * setting time but don't check between
+ * times. */
+ Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as instances. If NULL, use the value from
+ * the class hierarchy. It's an error at
+ * [oo::objdefine]/[self] call time if this
+ * namespace is defined but doesn't exist; we
+ * also check at setting time but don't check
+ * between times. */
} Class;
/*
@@ -372,6 +424,11 @@ typedef struct CallContext {
#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
#define CONSTRUCTOR 0x08 /* This is a constructor. */
#define DESTRUCTOR 0x10 /* This is a destructor. */
+#define TRUE_PRIVATE_METHOD 0x20
+ /* This is a private method only accessible
+ * from other methods defined on this class
+ * or instance. [TIP #500] */
+#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
/*
* Structure containing definition information about basic class methods.
@@ -390,89 +447,40 @@ typedef struct {
*/
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
-MODULE_SCOPE int TclOODefineObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOUnknownDefinition(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOONextObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOONextToObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOSelfObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd;
/*
* Method implementations (in tclOOBasic.c).
*/
-MODULE_SCOPE int TclOO_Class_Constructor(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_Create(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_New(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Destroy(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Eval(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Unknown(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_VarName(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_New;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Destroy;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName;
/*
* Private definitions, some of which perhaps ought to be exposed properly or
@@ -484,6 +492,17 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
+MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr);
+MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType *typePtr,
+ void *clientData);
+MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType *typePtr,
+ void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
@@ -504,7 +523,10 @@ MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
+ Object *contextObjPtr, Class *contextClsPtr,
Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
+ Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
@@ -513,7 +535,8 @@ 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,
+MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr,
+ Object *contextObj, Class *contextCls, int flags,
const char ***stringsPtr);
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
@@ -564,21 +587,32 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
} else if ((var) = (ary).list[i], 1)
/*
+ * A variation where the array is an array of structs. There's no issue with
+ * possible NULLs; every element of the array will be iterated over and the
+ * varable set to a pointer to each of those elements in turn.
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH_STRUCT(var,ary) \
+ for(i=0 ; var=&((ary).list[i]), i<(ary).num; 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.
+ * REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#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))
+ (*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\
+ *(void **)&(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))
+ (*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index c65003f..73368e4 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -3,7 +3,7 @@
*
* This file contains code to create and manage methods.
*
- * Copyright (c) 2005-2011 Donal K. Fellows
+ * Copyright © 2005-2011 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -80,12 +80,9 @@ static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
static void DeleteProcedureMethod(void *clientData);
static int CloneProcedureMethod(Tcl_Interp *interp,
void *clientData, void **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 ProcErrorProc MethodErrorHandler;
+static ProcErrorProc ConstructorErrorHandler;
+static ProcErrorProc DestructorErrorHandler;
static Tcl_Obj * RenderDeclarerName(void *clientData);
static int InvokeForwardMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
@@ -93,13 +90,8 @@ static int InvokeForwardMethod(void *clientData,
static void DeleteForwardMethod(void *clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
void *clientData, void **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);
+static Tcl_ResolveVarProc ProcedureMethodVarResolver;
+static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
/*
* The types of methods defined by the core OO system.
@@ -121,7 +113,7 @@ static const Tcl_MethodType fwdMethodType = {
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
- ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
@@ -134,8 +126,8 @@ static const Tcl_MethodType fwdMethodType = {
*/
Tcl_Method
-Tcl_NewInstanceMethod(
- Tcl_Interp *interp, /* Unused? */
+TclNewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
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,
@@ -186,11 +178,59 @@ Tcl_NewInstanceMethod(
mPtr->declaringObjectPtr = oPtr;
mPtr->declaringClassPtr = NULL;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ oPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
oPtr->epoch++;
return (Tcl_Method) mPtr;
}
+Tcl_Method
+Tcl_NewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ 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. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
+Tcl_Method
+Tcl_NewInstanceMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ 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_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -203,8 +243,8 @@ Tcl_NewInstanceMethod(
*/
Tcl_Method
-Tcl_NewMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
+TclNewMethod(
+ TCL_UNUSED(Tcl_Interp *),
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
@@ -250,11 +290,57 @@ Tcl_NewMethod(
mPtr->declaringObjectPtr = NULL;
mPtr->declaringClassPtr = clsPtr;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ clsPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
return (Tcl_Method) mPtr;
}
+
+Tcl_Method
+Tcl_NewMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ 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. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
+}
+
+Tcl_Method
+Tcl_NewMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ 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_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -304,7 +390,7 @@ TclOONewBasicMethod(
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
- Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
Tcl_DecrRefCount(namePtr);
}
@@ -339,7 +425,7 @@ TclOONewProcInstanceMethod(
ProcedureMethod *pmPtr;
Tcl_Method method;
- if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
@@ -397,7 +483,7 @@ TclOONewProcMethod(
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
- } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ } else if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
@@ -529,7 +615,7 @@ TclOOMakeProcInstanceMethod(
}
}
- return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
@@ -642,7 +728,7 @@ TclOOMakeProcMethod(
}
}
- return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
clientData);
}
@@ -793,6 +879,7 @@ PushMethodCallFrame(
int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
+ ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
@@ -858,10 +945,8 @@ PushMethodCallFrame(
* alternative is *so* slow...
*/
- if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
-
+ ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr) {
codePtr->nsPtr = nsPtr;
}
result = TclProcCompileProc(interp, pmPtr->procPtr,
@@ -930,7 +1015,7 @@ PushMethodCallFrame(
* 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]
+ * force LVT presence. [TIP #320, #500]
*
* ----------------------------------------------------------------------
*/
@@ -953,7 +1038,7 @@ ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
- int flags,
+ TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
Tcl_Var *varPtr)
{
int result;
@@ -986,6 +1071,7 @@ ProcedureMethodCompiledVarConnect(
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
int i, isNew, cacheIt, varLen, len;
const char *match, *varName;
@@ -1019,6 +1105,15 @@ ProcedureMethodCompiledVarConnect(
varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
if (contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr != NULL) {
+ FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 0;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
@@ -1028,6 +1123,14 @@ ProcedureMethodCompiledVarConnect(
}
}
} else {
+ FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 1;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->oPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
if ((len == varLen) && !memcmp(match, varName, len)) {
@@ -1082,10 +1185,10 @@ ProcedureMethodCompiledVarDelete(
static int
ProcedureMethodCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *varName,
int length,
- Tcl_Namespace *contextNs,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
@@ -1153,6 +1256,8 @@ RenderDeclarerName(
* ----------------------------------------------------------------------
*/
+/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
+
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
@@ -1160,15 +1265,15 @@ RenderDeclarerName(
static void
MethodErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* We pull the method name out of context instead of from argument */
{
int nameLen, objectNameLen;
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
- Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
+ TclGetStringFromObj(mPtr->namePtr, &nameLen);
Object *declarerPtr;
- (void)methodNameObj;/* We pull the method name out of context instead of from argument */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1192,14 +1297,14 @@ MethodErrorHandler(
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the constructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
- (void)methodNameObj;/* Ignore. We know it is the constructor. */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1222,14 +1327,14 @@ ConstructorErrorHandler(
static void
DestructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the destructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
- (void)methodNameObj; /* Ignore. We know it is the destructor. */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1319,7 +1424,7 @@ CloneProcedureMethod(
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
Tcl_GetString(bodyObj);
- TclFreeIntRep(bodyObj);
+ Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
@@ -1370,7 +1475,7 @@ TclOONewForwardInstanceMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
@@ -1383,7 +1488,7 @@ TclOONewForwardInstanceMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
+ return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
@@ -1409,7 +1514,7 @@ TclOONewForwardMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
@@ -1422,7 +1527,7 @@ TclOONewForwardMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
@@ -1457,7 +1562,7 @@ InvokeForwardMethod(
* can ignore here.
*/
- TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
+ TclListObjGetElementsM(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
@@ -1505,7 +1610,7 @@ DeleteForwardMethod(
static int
CloneForwardMethod(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
@@ -1548,9 +1653,7 @@ TclOOGetMethodBody(
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
- if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
- }
+ (void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
@@ -1655,6 +1758,23 @@ Tcl_MethodName(
}
int
+TclMethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
@@ -1662,6 +1782,9 @@ Tcl_MethodIsType(
{
Method *mPtr = (Method *) method;
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
+ }
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
@@ -1672,11 +1795,38 @@ Tcl_MethodIsType(
}
int
+Tcl_MethodIsType2(
+ Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
+ }
+ if (mPtr->typePtr == (const Tcl_MethodType *)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;
}
+
+int
+Tcl_MethodIsPrivate(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
+}
/*
* Extended method construction for itcl-ng.
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..f2e99b0
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,263 @@
+/*
+ * tclOOScript.h --
+ *
+ * This file contains support scripts for TclOO. They are defined here so
+ * that the code can be definitely run even in safe interpreters; TclOO's
+ * core setup is safe.
+ *
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ *
+ * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which
+ * contains the commented version of everything; *this* file is automatically
+ * generated.
+ */
+
+static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
+"::namespace eval ::oo {\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name args} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\t\t}\n"
+"\t\t::set cls [::uplevel 1 self]\n"
+"\t\t::if {$argc == 4} {\n"
+"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Resolve list {\n"
+"\t\t\treturn $list\n"
+"\t\t}\n"
+"\t\tmethod -set args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\ttailcall my Set $args\n"
+"\t\t}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
+"\t\t}\n"
+"\t\tmethod -remove args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [lmap val $current {\n"
+"\t\t\t\tif {$val in $args} continue else {set val}\n"
+"\t\t\t}]\n"
+"\t\t}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\texport -set -append -clear -prepend -remove\n"
+"\t\tunexport unknown destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
+"}\n"
+/* !END!: Do not edit above this line. */
+;
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index 735d871..7b653cb 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -14,8 +14,6 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#pragma GCC dependency "tclOO.decls"
#endif
-#define TclOOUnusedStubEntry 0
-
/* !BEGIN!: Do not edit below this line. */
static const TclOOIntStubs tclOOIntStubs = {
@@ -75,12 +73,12 @@ const TclOOStubs tclOOStubs = {
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
- 0, /* 29 */
- 0, /* 30 */
- 0, /* 31 */
- 0, /* 32 */
- 0, /* 33 */
- TclOOUnusedStubEntry, /* 34 */
+ Tcl_MethodIsPrivate, /* 29 */
+ Tcl_GetClassOfObject, /* 30 */
+ Tcl_GetObjectClassName, /* 31 */
+ Tcl_MethodIsType2, /* 32 */
+ Tcl_NewInstanceMethod2, /* 33 */
+ Tcl_NewMethod2, /* 34 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index a9fa212..221d99a 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -35,14 +35,19 @@ TclOOInitializeStubs(
const char *version)
{
int exact = 0;
- const char *packageName = "TclOO";
+ const char *packageName = "tcl::oo";
const char *errMsg = NULL;
TclOOStubs *stubsPtr = NULL;
const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
- return NULL;
+ packageName = "TclOO";
+ actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
+ if (actualVersion == NULL) {
+ return NULL;
+ }
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 531a256..e496b1e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4,19 +4,20 @@
* This file contains Tcl object-related functions that are used by many
* Tcl commands.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
- * Copyright (c) 2001 by ActiveState Corporation.
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
+ * Copyright © 2001 ActiveState Corporation.
+ * Copyright © 2005 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 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.
*/
#include "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
+#include <assert.h>
/*
* Table of all object types.
@@ -37,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL;
* TclNewObj macro, however, so must be visible.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
MODULE_SCOPE Tcl_Mutex tclObjMutex;
Tcl_Mutex tclObjMutex;
#endif
@@ -49,9 +50,8 @@ Tcl_Mutex tclObjMutex;
*/
char tclEmptyString = '\0';
-char *tclEmptyStringRep = &tclEmptyString;
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
/*
* 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,
@@ -76,7 +76,7 @@ typedef struct ObjData {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
@@ -88,7 +88,7 @@ typedef struct ThreadSpecificData {
* 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)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
* that a Tcl_Obj was not allocated by some
* other thread. */
@@ -97,7 +97,7 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
-static void TclThreadFinalizeContLines(ClientData clientData);
+static void TclThreadFinalizeContLines(void *clientData);
static ThreadSpecificData *TclGetContLineTable(void);
/*
@@ -157,7 +157,7 @@ typedef struct PendingObjData {
/*
* Macro to set up the local reference to the deletion context.
*/
-#ifndef TCL_THREADS
+#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
@@ -169,7 +169,7 @@ static __thread PendingObjData pendingObjData;
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
- Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
+ (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
@@ -182,26 +182,12 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
- } else { \
- if ((bignum).alloc > 0x7FFF) { \
- mp_shrink(&(bignum)); \
- } \
+ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
-#define UNPACK_BIGNUM(objPtr, bignum) \
- if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \
- (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \
- } else { \
- (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \
- (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \
- (bignum).alloc = \
- (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \
- (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \
- }
-
/*
* Prototypes for functions defined later in this file:
*/
@@ -211,9 +197,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef TCL_WIDE_INT_IS_LONG
-static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
-static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void UpdateStringOfOldInt(Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -243,6 +228,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
@@ -250,6 +236,7 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
+#endif
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
@@ -265,19 +252,23 @@ const Tcl_ObjType tclDoubleType = {
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG)
"int", /* name */
+#else
+ "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/
+#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef TCL_WIDE_INT_IS_LONG
-const Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static const Tcl_ObjType oldIntType = {
+ "int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+ UpdateStringOfOldInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
@@ -345,7 +336,7 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ unsigned long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
@@ -361,7 +352,7 @@ typedef struct ResolvedCmdName {
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName object
+ size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -396,21 +387,23 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
- Tcl_RegisterObjType(&tclEndOffsetType);
- Tcl_RegisterObjType(&tclIntType);
+#if (TCL_UTF_MAX < 4) || !defined(TCL_NO_DEPRECATED)
Tcl_RegisterObjType(&tclStringType);
+#endif
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
- Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ Tcl_RegisterObjType(&tclIntType);
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ Tcl_RegisterObjType(&oldIntType);
+#endif
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef TCL_WIDE_INT_IS_LONG
- Tcl_RegisterObjType(&tclWideIntType);
#endif
#ifdef TCL_COMPILE_STATS
@@ -448,7 +441,7 @@ TclInitObjSubsystem(void)
void
TclFinalizeThreadObjects(void)
{
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -457,7 +450,7 @@ TclFinalizeThreadObjects(void)
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
@@ -576,7 +569,7 @@ TclContinuationsEnter(
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
- ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1U) *sizeof(int));
+ ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int));
if (!newEntry) {
/*
@@ -733,7 +726,7 @@ TclContinuationsCopy(
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
- ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
+ ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
@@ -769,7 +762,7 @@ TclContinuationsGet(
if (!hPtr) {
return NULL;
}
- return Tcl_GetHashValue(hPtr);
+ return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
@@ -792,7 +785,7 @@ TclContinuationsGet(
static void
TclThreadFinalizeContLines(
- ClientData clientData)
+ TCL_UNUSED(void *))
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -884,7 +877,7 @@ Tcl_AppendAllObjTypes(
* Get the test for a valid list out of the way first.
*/
- if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
+ if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
@@ -897,7 +890,7 @@ Tcl_AppendAllObjTypes(
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
+ Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
@@ -930,7 +923,7 @@ Tcl_GetObjType(
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
- typePtr = Tcl_GetHashValue(hPtr);
+ typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
@@ -1001,11 +994,11 @@ Tcl_ConvertToType(
*--------------------------------------------------------------
*/
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
void
TclDbDumpActiveObjects(
FILE *outFile)
{
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
@@ -1017,7 +1010,7 @@ TclDbDumpActiveObjects(
fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
@@ -1030,8 +1023,14 @@ TclDbDumpActiveObjects(
}
}
}
-#endif
}
+#else
+void
+TclDbDumpActiveObjects(
+ TCL_UNUSED(FILE *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -1061,11 +1060,10 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
objPtr->typePtr = NULL;
+ TclInitStringRep(objPtr, NULL, 0);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Add entry to a thread local map used to check if a Tcl_Obj was
* allocated by the currently executing thread.
@@ -1202,10 +1200,8 @@ Tcl_DbNewObj(
Tcl_Obj *
Tcl_DbNewObj(
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewObj();
}
@@ -1301,7 +1297,7 @@ TclFreeObj(
ObjInitDeletionContext(context);
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -1323,7 +1319,7 @@ TclFreeObj(
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
@@ -1379,7 +1375,7 @@ TclFreeObj(
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
- TclFreeIntRep(objToFree);
+ TclFreeInternalRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
ckfree(objToFree);
@@ -1598,7 +1594,7 @@ TclSetDuplicateObj(
Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
TclInvalidateStringRep(dupPtr);
- TclFreeIntRep(dupPtr);
+ TclFreeInternalRep(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
}
@@ -1623,37 +1619,36 @@ TclSetDuplicateObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetString
char *
Tcl_GetString(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
- if (objPtr->bytes != NULL) {
- 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) {
+ if (objPtr->bytes == 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.
+ * 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.
*/
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- 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);
+ 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.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ 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;
}
@@ -1661,7 +1656,7 @@ Tcl_GetString(
/*
*----------------------------------------------------------------------
*
- * Tcl_GetStringFromObj --
+ * Tcl_GetStringFromObj/TclGetStringFromObj --
*
* Returns the string representation's byte array pointer and length for
* an object.
@@ -1681,6 +1676,7 @@ Tcl_GetString(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
@@ -1689,11 +1685,180 @@ Tcl_GetStringFromObj(
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- (void) TclGetString(objPtr);
+ if (objPtr->bytes == NULL) {
+ /*
+ * 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.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ 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);
+ }
+ }
+ if (lengthPtr != NULL) {
+ *lengthPtr = objPtr->length;
+ }
+ return objPtr->bytes;
+}
+
+#undef TclGetStringFromObj
+char *
+TclGetStringFromObj(
+ Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
+ * be returned. */
+ size_t *lengthPtr) /* If non-NULL, the location where the string
+ * rep's byte array length should * be stored.
+ * If NULL, no length is stored. */
+{
+ if (objPtr->bytes == NULL) {
+ /*
+ * 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.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ 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);
+ }
+ }
if (lengthPtr != NULL) {
+#if TCL_MAJOR_VERSION > 8
*lengthPtr = objPtr->length;
+#else
+ *lengthPtr = ((size_t)(unsigned)(objPtr->length + 1)) - 1;
+#endif
+ }
+ return objPtr->bytes;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitStringRep --
+ *
+ * This function is called in several configurations to provide all
+ * the tools needed to set an object's string representation. The
+ * function is determined by the arguments.
+ *
+ * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0)
+ * Invalid call -- panic!
+ *
+ * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0
+ * Allocation only - allocate space for (numBytes+1) chars.
+ * store in objPtr->bytes and return. Also sets
+ * objPtr->length to 0 and objPtr->bytes[0] to NUL.
+ *
+ * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0
+ * Allocate and copy. bytes is assumed to point to chars to
+ * copy into the string rep. objPtr->length = numBytes. Allocate
+ * array of (numBytes + 1) chars. store in objPtr->bytes. Copy
+ * numBytes chars from bytes to objPtr->bytes; Set
+ * objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
+ * Caller must guarantee there are numBytes chars at bytes to
+ * be copied.
+ *
+ * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0
+ * Truncate. Set objPtr->length to numBytes and
+ * objPr->bytes[numBytes] to NUL. Caller has to guarantee
+ * that a prior allocating call allocated enough bytes for
+ * this to be valid. Return objPtr->bytes.
+ *
+ * Caller is expected to ascertain that the bytes copied into
+ * the string rep make up complete valid UTF-8 characters.
+ *
+ * Results:
+ * A pointer to the string rep of objPtr.
+ *
+ * Side effects:
+ * As described above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_InitStringRep(
+ Tcl_Obj *objPtr, /* Object whose string rep is to be set */
+ const char *bytes,
+ unsigned int numBytes)
+{
+ assert(objPtr->bytes == NULL || bytes == NULL);
+
+ if (numBytes > INT_MAX) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ if (objPtr->bytes == NULL) {
+ /* Start with no string rep */
+ if (numBytes == 0) {
+ TclInitStringRep(objPtr, NULL, 0);
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ if (bytes) {
+ memcpy(objPtr->bytes, bytes, numBytes);
+ }
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
+ } else if (objPtr->bytes == &tclEmptyString) {
+ /* Start with empty string rep (not allocated) */
+ if (numBytes == 0) {
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
+ } else {
+ /* Start with non-empty string rep (allocated) */
+ if (numBytes == 0) {
+ ckfree(objPtr->bytes);
+ TclInitStringRep(objPtr, NULL, 0);
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes,
+ numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
}
+
return objPtr->bytes;
}
@@ -1726,6 +1891,117 @@ Tcl_InvalidateStringRep(
/*
*----------------------------------------------------------------------
*
+ * Tcl_HasStringRep --
+ *
+ * This function reports whether object has a string representation.
+ *
+ * Results:
+ * Boolean.
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_HasStringRep(
+ Tcl_Obj *objPtr) /* Object to test */
+{
+ return TclHasStringRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StoreInternalRep --
+ *
+ * This function is called to set the object's internal
+ * representation to match a particular type.
+ *
+ * It is the caller's responsibility to guarantee that
+ * the value of the submitted internalrep is in agreement with
+ * the value of any existing string rep.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_StoreInternalRep(
+ Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
+ const Tcl_ObjType *typePtr, /* New type for the object */
+ const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */
+{
+ /* Clear out any existing internalrep ( "shimmer" ) */
+ TclFreeInternalRep(objPtr);
+
+ /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */
+ if (irPtr) {
+ /* Copy the new internalrep into place */
+ objPtr->internalRep = *irPtr;
+
+ /* Set the type to match */
+ objPtr->typePtr = typePtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FetchInternalRep --
+ *
+ * This function is called to retrieve the object's internal
+ * representation matching a requested type, if any.
+ *
+ * Results:
+ * A read-only pointer to the associated Tcl_ObjInternalRep, or
+ * NULL if no such internal representation exists.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_ObjInternalRep *
+Tcl_FetchInternalRep(
+ Tcl_Obj *objPtr, /* Object to fetch from. */
+ const Tcl_ObjType *typePtr) /* Requested type */
+{
+ return TclFetchInternalRep(objPtr, typePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeInternalRep --
+ *
+ * This function is called to free an object's internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets typePtr field to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeInternalRep(
+ Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */
+{
+ TclFreeInternalRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
@@ -1734,7 +2010,7 @@ Tcl_InvalidateStringRep(
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
- * of calling the debugging version Tcl_DbNewBooleanObj.
+ * of calling the debugging version Tcl_DbNewLongObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
@@ -1753,7 +2029,7 @@ Tcl_Obj *
Tcl_NewBooleanObj(
int intValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewBooleanObj(intValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -1764,7 +2040,7 @@ Tcl_NewBooleanObj(
{
Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, intValue);
+ TclNewIntObj(objPtr, intValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1795,6 +2071,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
@@ -1809,9 +2086,10 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (intValue? 1 : 0);
+ objPtr->internalRep.wideValue = (intValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1821,10 +2099,8 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
int intValue, /* Boolean used to initialize new object. */
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBooleanObj(intValue);
}
@@ -1858,13 +2134,14 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetLongObj(objPtr, (intValue)!=0);
+ TclSetIntObj(objPtr, intValue!=0);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
- * Tcl_GetBooleanFromObj --
+ * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
* includes conversion from any of Tcl's numeric types.
@@ -1880,20 +2157,36 @@ Tcl_SetBooleanObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetBoolFromObj
int
-Tcl_GetBooleanFromObj(
+Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
- int *intPtr) /* Place to store resulting boolean. */
+ int flags,
+ char *charPtr) /* Place to store resulting boolean. */
{
+ int result;
+
+ if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
+ result = -1;
+ goto boolEnd;
+ } else if (objPtr == NULL) {
+ if (interp) {
+ TclNewObj(objPtr);
+ TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
+ ? "boolean value or \"\"" : "boolean value", NULL, -1, NULL, 0);
+ Tcl_DecrRefCount(objPtr);
+ }
+ return TCL_ERROR;
+ }
do {
if (objPtr->typePtr == &tclIntType) {
- *intPtr = (objPtr->internalRep.longValue != 0);
- return TCL_OK;
+ result = (objPtr->internalRep.wideValue != 0);
+ goto boolEnd;
}
if (objPtr->typePtr == &tclBooleanType) {
- *intPtr = (int) objPtr->internalRep.longValue;
- return TCL_OK;
+ result = objPtr->internalRep.longValue != 0;
+ goto boolEnd;
}
if (objPtr->typePtr == &tclDoubleType) {
/*
@@ -1909,24 +2202,45 @@ Tcl_GetBooleanFromObj(
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
- *intPtr = (d != 0.0);
- return TCL_OK;
+ result = (d != 0.0);
+ goto boolEnd;
}
if (objPtr->typePtr == &tclBignumType) {
- *intPtr = 1;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *intPtr = (objPtr->internalRep.wideValue != 0);
+ result = 1;
+ boolEnd:
+ if (charPtr != NULL) {
+ flags &= (TCL_NULL_OK-2);
+ if (flags) {
+ if (flags == (int)sizeof(int)) {
+ *(int *)charPtr = result;
+ return TCL_OK;
+ } else if (flags == (int)sizeof(short)) {
+ *(short *)charPtr = result;
+ return TCL_OK;
+ } else {
+ Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj");
+ }
+ }
+ *charPtr = result;
+ }
return TCL_OK;
}
-#endif
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
- TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
+ TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
+ ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
}
+#undef Tcl_GetBooleanFromObj
+int
+Tcl_GetBooleanFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* The object from which to get boolean. */
+ int *intPtr) /* Place to store resulting boolean. */
+{
+ return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1942,7 +2256,12 @@ Tcl_GetBooleanFromObj(
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
- * representation and the type of "objPtr" is set to boolean.
+ * representation and the type of "objPtr" is set to boolean or int/wideInt.
+ *
+ * Warning: If the returned type is "wideInt" (32-bit platforms) and your
+ * platform is bigendian, you cannot use internalRep.longValue to distinguish
+ * between false and true. On Windows and most other platforms this still will
+ * work fine, but basically it is non-portable.
*
*----------------------------------------------------------------------
*/
@@ -1960,8 +2279,7 @@ TclSetBooleanFromAny(
if (objPtr->bytes == NULL) {
if (objPtr->typePtr == &tclIntType) {
- switch (objPtr->internalRep.longValue) {
- case 0L: case 1L:
+ if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
@@ -1971,12 +2289,6 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- goto badBoolean;
- }
-#endif
-
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
@@ -1989,7 +2301,7 @@ TclSetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
- const char *str = TclGetStringFromObj(objPtr, &length);
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
@@ -2005,9 +2317,10 @@ static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
{
- int i, length, newBool;
+ int newBool;
char lowerCase[6];
- const char *str = TclGetStringFromObj(objPtr, &length);
+ const char *str = TclGetString(objPtr);
+ size_t i, length = objPtr->length;
if ((length == 0) || (length > 5)) {
/*
@@ -2105,14 +2418,14 @@ ParseBoolean(
*/
goodBoolean:
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
- TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = newBool;
+ TclFreeInternalRep(objPtr);
+ objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
@@ -2201,6 +2514,7 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
@@ -2213,10 +2527,8 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
@@ -2280,7 +2592,7 @@ Tcl_GetDoubleFromObj(
{
do {
if (objPtr->typePtr == &tclDoubleType) {
- if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
@@ -2293,22 +2605,16 @@ Tcl_GetDoubleFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *dblPtr = objPtr->internalRep.longValue;
+ *dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
- UNPACK_BIGNUM(objPtr, big);
+ TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *dblPtr = (double) objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
@@ -2367,15 +2673,12 @@ static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
- char buffer[TCL_DOUBLE_SPACE];
- int len;
+ char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
- Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
- len = strlen(buffer);
+ TclOOM(dst, TCL_DOUBLE_SPACE + 1);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
+ Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
@@ -2408,6 +2711,7 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
@@ -2415,7 +2719,7 @@ Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
- return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -2430,6 +2734,7 @@ Tcl_NewIntObj(
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2448,7 +2753,7 @@ Tcl_NewIntObj(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
@@ -2461,32 +2766,30 @@ Tcl_SetIntObj(
TclSetIntObj(objPtr, intValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
- * Retrieve the integer value of 'objPtr'.
- *
- * Value
- *
- * TCL_OK
- *
- * Success.
+ * Attempt to return an int from the Tcl object "objPtr". If the object
+ * is not already an int, an attempt will be made to convert it to one.
*
- * TCL_ERROR
- *
- * An error occurred during conversion or the integral value can not
- * be represented as an integer (it might be too large). An error
- * message is left in the interpreter's result if 'interp' is not
- * NULL.
+ * Integer and long integer objects share the same "integer" type
+ * implementation. We store all integers as longs and Tcl_GetIntFromObj
+ * checks whether the current value of the long can be represented by an
+ * int.
*
- * Effect
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion or if the long integer held by the object can not be
+ * represented by an int, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
- * 'objPtr' is converted to an integer if necessary if it is not one
- * already. The conversion frees any previously-existing internal
- * representation.
+ * Side effects:
+ * If the object is not already an int, the conversion will free any old
+ * internal representation.
*
*----------------------------------------------------------------------
*/
@@ -2500,20 +2803,12 @@ Tcl_GetIntFromObj(
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
- void *p;
- int type;
+ long l;
- if ((TclGetNumberFromObj(NULL, objPtr, &p, &type) != TCL_OK)
- || (type == TCL_NUMBER_DOUBLE)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "expected integer but got \"%s\"", Tcl_GetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
- }
+ if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
- if ((type != TCL_NUMBER_LONG) || ((ULONG_MAX > UINT_MAX)
- && ((*(long *)p > UINT_MAX) || (*(long *)p < -(long)UINT_MAX)))) {
+ if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent";
@@ -2522,10 +2817,11 @@ Tcl_GetIntFromObj(
}
return TCL_ERROR;
}
- *intPtr = (int)*(long *)p;
+ *intPtr = (int) l;
return TCL_OK;
#endif
}
+
/*
*----------------------------------------------------------------------
@@ -2548,9 +2844,8 @@ SetIntFromAny(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
- long l;
-
- return TclGetLongFromObj(interp, objPtr, &l);
+ Tcl_WideInt w;
+ return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
/*
@@ -2576,15 +2871,25 @@ static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
- char buffer[TCL_INTEGER_SPACE];
- int len;
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
+
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.wideValue));
+}
- len = TclFormatInt(buffer, objPtr->internalRep.longValue);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void
+UpdateStringOfOldInt(
+ Tcl_Obj *objPtr) /* Int object whose string rep to update. */
+{
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.longValue));
}
+#endif
/*
*----------------------------------------------------------------------
@@ -2616,15 +2921,16 @@ UpdateStringOfInt(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewLongObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
- return Tcl_DbNewLongObj(longValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -2636,10 +2942,11 @@ Tcl_NewLongObj(
{
Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, longValue);
+ TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2673,6 +2980,8 @@ Tcl_NewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
@@ -2687,9 +2996,10 @@ Tcl_DbNewLongObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep */
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = longValue;
+ objPtr->internalRep.wideValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -2700,14 +3010,13 @@ Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- return Tcl_NewLongObj(longValue);
+ return Tcl_NewWideIntObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2727,6 +3036,8 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2737,8 +3048,9 @@ Tcl_SetLongObj(
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- TclSetLongObj(objPtr, longValue);
+ TclSetIntObj(objPtr, longValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2768,14 +3080,15 @@ Tcl_GetLongFromObj(
long *longPtr) /* Place to store resulting long. */
{
do {
+#ifdef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclIntType) {
- *longPtr = objPtr->internalRep.longValue;
+ *longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
+#else
+ if (objPtr->typePtr == &tclIntType) {
/*
- * We return any integer in the range -ULONG_MAX to ULONG_MAX
+ * We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
@@ -2784,9 +3097,9 @@ Tcl_GetLongFromObj(
Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX)
+ if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
- *longPtr = Tcl_WideAsLong(w);
+ *longPtr = (long)w;
return TCL_OK;
}
goto tooLarge;
@@ -2809,28 +3122,30 @@ Tcl_GetLongFromObj(
* values in the unsigned long range will fit in a long.
*/
+ {
mp_int big;
+ unsigned long scratch, value = 0;
+ unsigned char *bytes = (unsigned char *) &scratch;
+ size_t numBytes;
- UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1)
- / MP_DIGIT_BIT) {
- unsigned long value = 0;
- size_t numBytes;
- long scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
- while (numBytes-- > 0) {
+ TclUnpackBignum(objPtr, big);
+ if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ if (value <= 1 + (unsigned long)LONG_MAX) {
+ *longPtr = (long)(-value);
+ return TCL_OK;
}
- if (big.sign) {
- *longPtr = (long) (-value);
- } else {
- *longPtr = (long) value;
+ } else {
+ if (value <= (unsigned long)ULONG_MAX) {
+ *longPtr = (long)value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
+ }
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
@@ -2847,49 +3162,6 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfWideInt --
- *
- * Update the string representation for a wide integer object. Note: this
- * function does not free an existing old string rep so storage will be
- * lost if this has not already been done.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object's string is set to a valid string that results from the
- * wideInt-to-string conversion.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfWideInt(
- Tcl_Obj *objPtr) /* Int object whose string rep to update. */
-{
- char buffer[TCL_INTEGER_SPACE+2];
- unsigned len;
- Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
-
- /*
- * Note that sprintf will generate a compiler warning under Mingw claiming
- * %I64 is an unknown format specifier. Just ignore this warning. We can't
- * use %L as the format specifier since that gets printed as a 32 bit
- * value.
- */
-
- sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
- len = strlen(buffer);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
-}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -2939,7 +3211,7 @@ Tcl_NewWideIntObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2991,7 +3263,7 @@ Tcl_DbNewWideIntObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
@@ -3002,10 +3274,8 @@ Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(wideValue);
}
@@ -3040,19 +3310,7 @@ Tcl_SetWideIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
- if ((wideValue >= (Tcl_WideInt) LONG_MIN)
- && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
- TclSetLongObj(objPtr, (long) wideValue);
- } else {
-#ifndef TCL_WIDE_INT_IS_LONG
- TclSetWideIntObj(objPtr, wideValue);
-#else
- mp_int big;
-
- TclBNInitBignumFromWideInt(&big, wideValue);
- Tcl_SetBignumObj(objPtr, &big);
-#endif
- }
+ TclSetIntObj(objPtr, wideValue);
}
/*
@@ -3084,14 +3342,8 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *wideIntPtr = objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
if (objPtr->typePtr == &tclIntType) {
- *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
+ *wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
@@ -3110,25 +3362,26 @@ Tcl_GetWideIntFromObj(
*/
mp_int big;
-
- UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt)
- + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- Tcl_WideUInt value = 0;
- size_t numBytes;
- Tcl_WideInt scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ TclUnpackBignum(objPtr, big);
+ if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
+ *wideIntPtr = (Tcl_WideInt)(-value);
+ return TCL_OK;
}
- if (big.sign) {
- *wideIntPtr = (Tcl_WideInt) (-value);
- } else {
- *wideIntPtr = (Tcl_WideInt) value;
+ } else {
+ if (value <= (Tcl_WideUInt)WIDE_MAX) {
+ *wideIntPtr = (Tcl_WideInt)value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
if (interp != NULL) {
@@ -3144,33 +3397,160 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
*
- * SetWideIntFromAny --
+ * Tcl_GetWideUIntFromObj --
*
- * Attempts to force the internal representation for a Tcl object to
- * tclWideIntType, specifically.
+ * Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the
+ * object is not already a wide int object or a bignum object, an attempt will
+ * be made to convert it to one.
*
* Results:
- * The return value is a standard object Tcl result. If an error occurs
+ * The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
+ * Side effects:
+ * If the object is not already an int object, the conversion will free
+ * any old internal representation.
+ *
*----------------------------------------------------------------------
*/
-static int
-SetWideIntFromAny(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *objPtr) /* Pointer to the object to convert */
+int
+Tcl_GetWideUIntFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideUInt *wideUIntPtr)
+ /* Place to store resulting long. */
{
- Tcl_WideInt w;
- return Tcl_GetWideIntFromObj(interp, objPtr, &w);
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ if (objPtr->internalRep.wideValue < 0) {
+ wideUIntOutOfRange:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected unsigned integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ }
+ return TCL_ERROR;
+ }
+ *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ goto wideUIntOutOfRange;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ /*
+ * Must check for those bignum values that can fit in a
+ * Tcl_WideUInt, even when auto-narrowing is enabled.
+ */
+
+ mp_int big;
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideUInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ TclUnpackBignum(objPtr, big);
+ if (big.sign == MP_NEG) {
+ goto wideUIntOutOfRange;
+ }
+ if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ *wideUIntPtr = (Tcl_WideUInt)value;
+ return TCL_OK;
+ }
+
+ if (interp != NULL) {
+ 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);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetWideBitsFromObj --
+ *
+ * Attempt to return a wide integer from the Tcl object "objPtr". If the
+ * object is not already a int, double or bignum, an attempt will be made
+ * to convert it to one of these. Out-of-range values don't result in an
+ * error, but only the least significant 64 bits will be returned.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int, double or bignum object, the
+ * conversion will free any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetWideBitsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
+{
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+ mp_err err;
+
+ Tcl_WideUInt value = 0, scratch;
+ size_t numBytes;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ Tcl_GetBignumFromObj(NULL, objPtr, &big);
+ err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
+ if (err == MP_OKAY) {
+ err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes);
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value;
+ mp_clear(&big);
+ return TCL_OK;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3191,7 +3571,7 @@ FreeBignum(
{
mp_int toFree; /* Bignum to free */
- UNPACK_BIGNUM(objPtr, toFree);
+ TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
ckfree(objPtr->internalRep.twoPtrValue.ptr1);
@@ -3224,7 +3604,7 @@ DupBignum(
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
- UNPACK_BIGNUM(srcPtr, bignumVal);
+ TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
@@ -3257,12 +3637,10 @@ UpdateStringOfBignum(
{
mp_int bignumVal;
int size;
- int status;
char *stringVal;
- UNPACK_BIGNUM(objPtr, bignumVal);
- status = mp_radix_size(&bignumVal, 10, &size);
- if (status != MP_OKAY) {
+ TclUnpackBignum(objPtr, bignumVal);
+ if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
@@ -3277,13 +3655,13 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = (char *)ckalloc(size);
- status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10);
- if (status != MP_OKAY) {
+
+ stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1);
+
+ TclOOM(stringVal, size);
+ if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
- objPtr->bytes = stringVal;
- objPtr->length = size - 1; /* size includes a trailing NUL byte. */
}
/*
@@ -3307,14 +3685,14 @@ UpdateStringOfBignum(
Tcl_Obj *
Tcl_NewBignumObj(
- mp_int *bignumValue)
+ void *bignumValue)
{
return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(
- mp_int *bignumValue)
+ void *bignumValue)
{
Tcl_Obj *objPtr;
@@ -3345,7 +3723,7 @@ Tcl_NewBignumObj(
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
+ void *bignumValue,
const char *file,
int line)
{
@@ -3358,9 +3736,9 @@ Tcl_DbNewBignumObj(
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
- const char *file,
- int line)
+ void *bignumValue,
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBignumObj(bignumValue);
}
@@ -3399,37 +3777,34 @@ GetBignumFromObj(
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
- UNPACK_BIGNUM(objPtr, temp);
+ TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "insufficient memory to unpack bignum", -1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- }
return TCL_ERROR;
}
} else {
- UNPACK_BIGNUM(objPtr, *bignumValue);
+ TclUnpackBignum(objPtr, *bignumValue);
+ /* Optimized TclFreeInternalRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
+ /*
+ * TODO: If objPtr has a string rep, this leaves
+ * it undisturbed. Not clear that's proper. Pure
+ * bignum values are converted to empty string.
+ */
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, NULL, 0);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- TclBNInitBignumFromWideInt(bignumValue,
- objPtr->internalRep.wideValue);
+ if (mp_init_i64(bignumValue,
+ objPtr->internalRep.wideValue) != MP_OKAY) {
+ return TCL_ERROR;
+ }
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3473,9 +3848,9 @@ int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
- mp_int *bignumValue) /* Returned bignum value. */
+ void *bignumValue) /* Returned bignum value. */
{
- return GetBignumFromObj(interp, objPtr, 1, bignumValue);
+ return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue);
}
/*
@@ -3508,9 +3883,9 @@ int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
- mp_int *bignumValue) /* Returned bignum value. */
+ void *bignumValue) /* Returned bignum value. */
{
- return GetBignumFromObj(interp, objPtr, 0, bignumValue);
+ return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue);
}
/*
@@ -3533,65 +3908,36 @@ Tcl_TakeBignumFromObj(
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
- mp_int *bignumValue) /* Value to store */
+ void *big) /* Value to store */
{
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideUInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+ mp_int *bignumValue = (mp_int *) big;
+
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
- if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- unsigned long value = 0;
- size_t numBytes;
- long scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(bignumValue, bytes, sizeof(long), &numBytes) != MP_OKAY) {
- goto tooLargeForLong;
- }
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
- }
- if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
- goto tooLargeForLong;
- }
- if (bignumValue->sign) {
- TclSetLongObj(objPtr, (long)(-value));
- } else {
- TclSetLongObj(objPtr, (long)value);
- }
- mp_clear(bignumValue);
- return;
+ if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) {
+ goto tooLargeForWide;
}
- tooLargeForLong:
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- Tcl_WideUInt value = 0;
- size_t numBytes;
- Tcl_WideInt scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
-
- if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideInt), &numBytes) != MP_OKAY) {
- goto tooLargeForWide;
- }
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
- }
- if (value > ((UWIDE_MAX >> 1) + bignumValue->sign)) {
- goto tooLargeForWide;
- }
- if (bignumValue->sign) {
- TclSetWideIntObj(objPtr, (Tcl_WideInt)(-value));
- } else {
- TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
- }
- mp_clear(bignumValue);
- return;
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) {
+ goto tooLargeForWide;
+ }
+ if (bignumValue->sign) {
+ TclSetIntObj(objPtr, (Tcl_WideInt)(-value));
+ } else {
+ TclSetIntObj(objPtr, (Tcl_WideInt)value);
}
+ mp_clear(bignumValue);
+ return;
tooLargeForWide:
-#endif
TclInvalidateStringRep(objPtr);
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
TclSetBignumInternalRep(objPtr, bignumValue);
}
@@ -3616,8 +3962,9 @@ Tcl_SetBignumObj(
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
- mp_int *bignumValue)
+ void *big)
{
+ mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
@@ -3636,7 +3983,7 @@ TclSetBignumInternalRep(
/*
*----------------------------------------------------------------------
*
- * TclGetNumberFromObj --
+ * Tcl_GetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
@@ -3654,15 +4001,15 @@ TclSetBignumInternalRep(
*/
int
-TclGetNumberFromObj(
+Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
- ClientData *clientDataPtr,
+ void **clientDataPtr,
int *typePtr)
{
do {
if (objPtr->typePtr == &tclDoubleType) {
- if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
@@ -3671,23 +4018,16 @@ TclGetNumberFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *typePtr = TCL_NUMBER_LONG;
- *clientDataPtr = &objPtr->internalRep.longValue;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *typePtr = TCL_NUMBER_WIDE;
+ *typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
- mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
- (int) sizeof(mp_int));
+ mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
+ sizeof(mp_int));
- UNPACK_BIGNUM(objPtr, *bigPtr);
+ TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
@@ -3696,6 +4036,107 @@ TclGetNumberFromObj(
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
}
+
+int
+Tcl_GetNumber(
+ Tcl_Interp *interp,
+ const char *bytes,
+ size_t numBytes,
+ void **clientDataPtr,
+ int *typePtr)
+{
+ static Tcl_ThreadDataKey numberCacheKey;
+ Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey,
+ sizeof(Tcl_Obj));
+
+ Tcl_FreeInternalRep(objPtr);
+
+ if (bytes == NULL) {
+ bytes = &tclEmptyString;
+ numBytes = 0;
+ }
+ if (numBytes == (size_t)TCL_INDEX_NONE) {
+ numBytes = strlen(bytes);
+ }
+ if (numBytes > INT_MAX) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ objPtr->bytes = (char *) bytes;
+ objPtr->length = numBytes;
+
+ return Tcl_GetNumberFromObj(interp, objPtr, clientDataPtr, typePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IncrRefCount --
+ *
+ * Increments the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IncrRefCount
+void
+Tcl_IncrRefCount(
+ Tcl_Obj *objPtr) /* The object we are registering a reference to. */
+{
+ ++(objPtr)->refCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DecrRefCount --
+ *
+ * Decrements the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_DecrRefCount
+void
+Tcl_DecrRefCount(
+ Tcl_Obj *objPtr) /* The object we are releasing a reference to. */
+{
+ if (objPtr->refCount-- <= 1) {
+ TclFreeObj(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsShared --
+ *
+ * Tests if the object has a ref count greater than one.
+ *
+ * Results:
+ * Boolean value that is the result of the test.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IsShared
+int
+Tcl_IsShared(
+ Tcl_Obj *objPtr) /* The object to test for being shared. */
+{
+ return ((objPtr)->refCount > 1);
+}
/*
*----------------------------------------------------------------------
@@ -3718,6 +4159,7 @@ TclGetNumberFromObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
@@ -3727,14 +4169,13 @@ Tcl_DbIncrRefCount(
int line) /* Line number in the source file; used for
* debugging. */
{
-#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("incrementing refCount of previously disposed object");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3756,9 +4197,19 @@ Tcl_DbIncrRefCount(
}
}
# endif /* TCL_THREADS */
-#endif /* TCL_MEM_DEBUG */
++(objPtr)->refCount;
}
+#else /* !TCL_MEM_DEBUG */
+void
+Tcl_DbIncrRefCount(
+ Tcl_Obj *objPtr, /* The object we are registering a reference
+ * to. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ ++(objPtr)->refCount;
+}
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -3781,6 +4232,7 @@ Tcl_DbIncrRefCount(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
@@ -3790,14 +4242,13 @@ Tcl_DbDecrRefCount(
int line) /* Line number in the source file; used for
* debugging. */
{
-#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("decrementing refCount of previously disposed object");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3819,12 +4270,24 @@ Tcl_DbDecrRefCount(
}
}
# endif /* TCL_THREADS */
-#endif /* TCL_MEM_DEBUG */
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
+#else /* !TCL_MEM_DEBUG */
+void
+Tcl_DbDecrRefCount(
+ Tcl_Obj *objPtr, /* The object we are releasing a reference
+ * to. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ if (objPtr->refCount-- <= 1) {
+ TclFreeObj(objPtr);
+ }
+}
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -3850,10 +4313,15 @@ Tcl_DbDecrRefCount(
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
+#ifdef TCL_MEM_DEBUG
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. */
+#else
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+#endif
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
@@ -3862,7 +4330,7 @@ Tcl_DbIsShared(
Tcl_Panic("checking whether previously disposed object is shared");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3947,7 +4415,7 @@ Tcl_InitObjHashTable(
static Tcl_HashEntry *
AllocObjEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
@@ -3982,7 +4450,7 @@ TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = keyPtr;
+ Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
const char *p1, *p2;
size_t l1, l2;
@@ -4066,15 +4534,15 @@ TclFreeObjEntry(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclHashObjKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
- Tcl_Obj *objPtr = keyPtr;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
- unsigned int result = 0;
+ const char *string = Tcl_GetStringFromObj(objPtr, &length);
+ TCL_HASH_TYPE result = 0;
/*
* I tried a zillion different hash functions and asked many other people
@@ -4169,12 +4637,11 @@ Tcl_GetCommandFromObj(
* to discard the old rep and create a new one.
*/
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (objPtr->typePtr == &tclCmdNameType) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
- && !(cmdPtr->flags & CMD_IS_DELETED)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
@@ -4194,11 +4661,11 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- /* See [] why we cannot call SetCmdNameFromAny() directly here. */
+ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
@@ -4222,57 +4689,78 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
-void
-TclSetCmdNameObj(
- Tcl_Interp *interp, /* Points to interpreter containing command
- * that should be cached in objPtr. */
- Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
- * CmdName object. */
- Command *cmdPtr) /* Points to Command structure that the
- * CmdName object should refer to. */
+static void
+SetCmdNameObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Command *cmdPtr,
+ ResolvedCmdName *resPtr)
{
Interp *iPtr = (Interp *) interp;
- ResolvedCmdName *resPtr;
- Namespace *currNsPtr;
- const char *name;
+ ResolvedCmdName *fillPtr;
+ const char *name = TclGetString(objPtr);
- if (objPtr->typePtr == &tclCmdNameType) {
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
- return;
- }
+ if (resPtr) {
+ fillPtr = resPtr;
+ } else {
+ fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
+ fillPtr->refCount = 1;
}
+ fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
+ fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
- name = TclGetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
+ /* NOTE: relying on NULL termination here. */
+ if ((name[0] == ':') && (name[1] == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * Fully qualified names always resolve to same thing. No need
+ * to record resolution context information.
*/
- resPtr->refNsPtr = NULL;
+ fillPtr->refNsPtr = NULL;
+ fillPtr->refNsId = 0; /* Will not be read */
+ fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
- * Get the current namespace.
+ * Record current state of current namespace as the resolution
+ * context of this command name lookup.
*/
+ Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
+
+ if (resPtr == NULL) {
+ TclFreeInternalRep(objPtr);
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
+}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+void
+TclSetCmdNameObj(
+ Tcl_Interp *interp, /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
+ * CmdName object. */
+ Command *cmdPtr) /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ ResolvedCmdName *resPtr;
+
+ if (objPtr->typePtr == &tclCmdNameType) {
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
+ }
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4301,15 +4789,14 @@ FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
- ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
- if (resPtr->refCount-- == 1) {
+ if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
@@ -4321,7 +4808,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4350,13 +4836,11 @@ DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- if (resPtr != NULL) {
resPtr->refCount++;
- }
copyPtr->typePtr = &tclCmdNameType;
}
@@ -4386,10 +4870,8 @@ SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
- Interp *iPtr = (Interp *) interp;
const char *name;
Command *cmdPtr;
- Namespace *currNsPtr;
ResolvedCmdName *resPtr;
if (interp == NULL) {
@@ -4409,59 +4891,31 @@ SetCmdNameFromAny(
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
- * Free the old internalRep before setting the new one. Do this after
- * getting the string rep to allow the conversion code (in particular,
- * Tcl_GetStringFromObj) to use that old internalRep.
+ * Stop shimmering and caching nothing when we found nothing. Just
+ * report the failure to find the command as an error.
*/
- if (cmdPtr) {
- cmdPtr->refCount++;
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- 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->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- }
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- if ((*name++ == ':') && (*name == ':')) {
- /*
- * The name is fully qualified: set the referring namespace to
- * NULL.
- */
+ if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
+ return TCL_ERROR;
+ }
- resPtr->refNsPtr = NULL;
- } else {
- /*
- * Get the current namespace.
- */
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
+ /*
+ * Re-use existing ResolvedCmdName struct when possible.
+ * Cleanup the old fields that need it.
+ */
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ Command *oldCmdPtr = resPtr->cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ if (oldCmdPtr->refCount-- <= 1) {
+ TclCleanupCommandMacro(oldCmdPtr);
}
} else {
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+ resPtr = NULL;
}
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
return TCL_OK;
}
@@ -4483,12 +4937,11 @@ SetCmdNameFromAny(
int
Tcl_RepresentationCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
@@ -4502,36 +4955,20 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(ptrBuffer, "%p", (void *) objv[1]);
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
- " object pointer at %s",
- objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
- objv[1]->refCount, ptrBuffer);
+ " object pointer at %p",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, objv[1]);
- /*
- * This is a workaround to silence reports from `make valgrind`
- * on 64-bit systems. The problem is that the test suite
- * includes calling the [represenation] command on values of
- * &tclDoubleType. When these values are created, the "doubleValue"
- * is set, but when the "twoPtrValue" is examined, its "ptr2"
- * field has never been initialized. Since [representation]
- * presents the value of the ptr2 value in its output, valgrind
- * alerts about the read of uninitialized memory.
- *
- * The general problem with [representation], that it can read
- * and report uninitialized fields, is still present. This is
- * just the minimal workaround to silence one particular test.
- */
-
- if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) {
- objv[1]->internalRep.twoPtrValue.ptr2 = NULL;
- }
if (objv[1]->typePtr) {
- sprintf(ptrBuffer, "%p:%p",
- (void *) objv[1]->internalRep.twoPtrValue.ptr1,
- (void *) objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
- ptrBuffer);
+ if (objv[1]->typePtr == &tclDoubleType) {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
+ objv[1]->internalRep.doubleValue);
+ } else {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ }
}
if (objv[1]->bytes) {
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index 03daa40..de28b0c 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -3,7 +3,7 @@
*
* This file contains the bytecode optimizer.
*
- * Copyright (c) 2013 by Donal Fellows.
+ * Copyright © 2013 Donal Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -233,7 +233,7 @@ ConvertZeroEffectToNOP(
TclGetUInt1AtPtr(currentInstPtr + 1));
int numBytes;
- (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ (void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
@@ -248,7 +248,7 @@ ConvertZeroEffectToNOP(
TclGetUInt4AtPtr(currentInstPtr + 1));
int numBytes;
- (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ (void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
@@ -429,9 +429,9 @@ void
TclOptimizeBytecode(
void *envPtr)
{
- ConvertZeroEffectToNOP(envPtr);
- AdvanceJumps(envPtr);
- TrimUnreachable(envPtr);
+ ConvertZeroEffectToNOP((CompileEnv *)envPtr);
+ AdvanceJumps((CompileEnv *)envPtr);
+ TrimUnreachable((CompileEnv *)envPtr);
}
/*
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index b03ad41..ba7e801 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -5,9 +5,9 @@
* applications will probably call Tcl_SetPanicProc() to set an
* application-specific panic procedure.
*
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1988-1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -23,8 +23,8 @@
* procedure.
*/
-#if defined(__CYGWIN__)
-static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic;
+#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8))
+static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic;
#else
static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
#endif
@@ -45,19 +45,21 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
*----------------------------------------------------------------------
*/
-void
+#undef Tcl_SetPanicProc
+const char *
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
- if ((proc != tclWinDebugPanic) || (panicProc == NULL))
+ if (((Tcl_PanicProc *)proc != tclWinDebugPanic) || (panicProc == NULL))
#elif defined(__CYGWIN__)
if (proc == NULL)
panicProc = tclWinDebugPanic;
else
#endif
panicProc = proc;
+ return Tcl_InitSubsystems();
}
/*
@@ -141,8 +143,6 @@ Tcl_PanicVA(
*----------------------------------------------------------------------
*/
-/* ARGSUSED */
-
/*
* The following comment is here so that Coverity's static analizer knows that
* a Tcl_Panic() call can never return and avoids lots of false positives.
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 5bbaf93..4de0356 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -5,8 +5,8 @@
* general-purpose fashion that can be used for many different purposes,
* including compilation, direct execution, code analysis, etc.
*
- * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Ajuba Solutions.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions.
* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution of
@@ -19,12 +19,7 @@
/*
* The following table provides parsing information about each possible 8-bit
- * character. The table is designed to be referenced with either signed or
- * unsigned characters, so it has 384 entries. The first 128 entries
- * correspond to negative character values, the next 256 correspond to
- * positive character values. The last 128 entries are identical to the first
- * 128. The table is always indexed with a 128-byte offset (the 128th entry
- * corresponds to a character value of 0).
+ * character. The table is designed to be referenced with unsigned characters.
*
* The macro CHAR_TYPE is used to index into the table and return information
* about its character argument. The following return values are defined.
@@ -44,42 +39,6 @@
*/
const char tclCharTypeTable[] = {
- /*
- * Negative character values, from -128 to -1:
- */
-
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
/*
* Positive character values, from 0-127:
@@ -160,13 +119,15 @@ const char tclCharTypeTable[] = {
* Prototypes for local functions defined in this file:
*/
-static inline int CommandComplete(const char *script, int numBytes);
+static int CommandComplete(const char *script, int numBytes);
static int ParseComment(const char *src, int numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, int numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static int ParseWhiteSpace(const char *src, int numBytes,
int *incompletePtr, char *typePtr);
+static int ParseAllWhiteSpace(const char *src, int numBytes,
+ int *incompletePtr);
static int ParseHex(const char *src, int numBytes,
int *resultPtr);
@@ -300,9 +261,43 @@ Tcl_ParseCommand(
*/
parsePtr->commandStart = src;
+ type = CHAR_TYPE(*src);
+ scanned = 1; /* Can't have missing whitepsace before first word. */
while (1) {
int expandWord = 0;
+ /* Are we at command termination? */
+
+ if ((numBytes == 0) || (type & terminators) != 0) {
+ parsePtr->term = src;
+ parsePtr->commandSize = src + (numBytes != 0)
+ - parsePtr->commandStart;
+ return TCL_OK;
+ }
+
+ /* Are we missing white space after previous word? */
+
+ if (scanned == 0) {
+ if (src[-1] == '"') {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
+ }
+ parsePtr->term = src;
+ error:
+ Tcl_FreeParse(parsePtr);
+ parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
+ return TCL_ERROR;
+ }
+
/*
* Create the token for the word.
*/
@@ -312,23 +307,6 @@ Tcl_ParseCommand(
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->type = TCL_TOKEN_WORD;
- /*
- * Skip white space before the word. Also skip a backslash-newline
- * sequence: it should be treated just like white space.
- */
-
- scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- src += scanned;
- numBytes -= scanned;
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
@@ -548,52 +526,12 @@ Tcl_ParseCommand(
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
- /*
- * Do two additional checks: (a) make sure we're really at the end of
- * a word (there might have been garbage left after a quoted or braced
- * word), and (b) check for the end of the command.
- */
+ /* Parse the whitespace between words. */
scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- if (scanned) {
- src += scanned;
- numBytes -= scanned;
- continue;
- }
-
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
- if (src[-1] == '"') {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-quote", -1));
- }
- parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
- } else {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-brace", -1));
- }
- parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
- }
- parsePtr->term = src;
- goto error;
+ src += scanned;
+ numBytes -= scanned;
}
-
- parsePtr->commandSize = src - parsePtr->commandStart;
- return TCL_OK;
-
- error:
- Tcl_FreeParse(parsePtr);
- parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
- return TCL_ERROR;
}
/*
@@ -735,23 +673,32 @@ ParseWhiteSpace(
*----------------------------------------------------------------------
*/
-int
-TclParseAllWhiteSpace(
+static int
+ParseAllWhiteSpace(
const char *src, /* First character to parse. */
- int numBytes) /* Max number of byes to scan */
+ int numBytes, /* Max number of byes to scan */
+ int *incompletePtr) /* Set true if parse is incomplete. */
{
- int dummy;
char type;
const char *p = src;
do {
- int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type);
+ int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);
p += scanned;
numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++, --numBytes));
return (p-src);
}
+
+int
+TclParseAllWhiteSpace(
+ const char *src, /* First character to parse. */
+ int numBytes) /* Max number of byes to scan */
+{
+ int dummy;
+ return ParseAllWhiteSpace(src, numBytes, &dummy);
+}
/*
*----------------------------------------------------------------------
@@ -839,13 +786,13 @@ TclParseBackslash(
* of bytes scanned should be written. */
char *dst) /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
- * written. At most TCL_UTF_MAX bytes will be
- * written there. */
+ * written. At most 4 bytes will be written there. */
{
const char *p = src+1;
+ int unichar;
int result;
int count;
- char buf[TCL_UTF_MAX] = "";
+ char buf[4] = "";
if (numBytes == 0) {
if (readPtr != NULL) {
@@ -921,7 +868,6 @@ TclParseBackslash(
* No hexdigits -> This is just "u".
*/
result = 'u';
-#if TCL_UTF_MAX > 3
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
@@ -932,7 +878,6 @@ TclParseBackslash(
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
-#endif
}
break;
case 'U':
@@ -942,11 +887,9 @@ TclParseBackslash(
* No hexdigits -> This is just "U".
*/
result = 'U';
-#if TCL_UTF_MAX > 3
- } else if ((result & ~0x7FF) == 0xD800) {
+ } else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
result = 0xFFFD;
-#endif
}
break;
case '\n':
@@ -992,15 +935,16 @@ TclParseBackslash(
* #217987] test subst-3.2
*/
- if (TclUCS4Complete(p, numBytes - 1)) {
- count = TclUtfToUCS4(p, &result) + 1; /* +1 for '\' */
+ if (Tcl_UtfCharComplete(p, numBytes - 1)) {
+ count = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
- count = TclUtfToUCS4(utfBytes, &result) + 1;
+ count = TclUtfToUCS4(utfBytes, &unichar) + 1;
}
+ result = unichar;
break;
}
@@ -1008,12 +952,12 @@ TclParseBackslash(
if (readPtr != NULL) {
*readPtr = count;
}
-#if TCL_UTF_MAX < 4
- if (result > 0xFFFF) {
- result = 0xFFFD;
+ count = Tcl_UniCharToUtf(result, dst);
+ if ((result >= 0xD800) && (count < 3)) {
+ /* Special case for handling high surrogates. */
+ count += Tcl_UniCharToUtf(-1, dst + count);
}
-#endif
- return TclUCS4ToUtf(result, dst);
+ return count;
}
/*
@@ -1043,17 +987,12 @@ ParseComment(
* command. */
{
const char *p = src;
+ int incomplete = parsePtr->incomplete;
while (numBytes) {
- char type;
- int scanned;
-
- do {
- scanned = ParseWhiteSpace(p, numBytes,
- &parsePtr->incomplete, &type);
- p += scanned;
- numBytes -= scanned;
- } while (numBytes && (*p == '\n') && (p++,numBytes--));
+ int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
+ p += scanned;
+ numBytes -= scanned;
if ((numBytes == 0) || (*p != '#')) {
break;
@@ -1062,35 +1001,28 @@ ParseComment(
parsePtr->commentStart = p;
}
+ p++;
+ numBytes--;
while (numBytes) {
+ if (*p == '\n') {
+ p++;
+ numBytes--;
+ break;
+ }
if (*p == '\\') {
- scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete,
- &type);
- if (scanned) {
- p += scanned;
- numBytes -= scanned;
- } else {
- /*
- * General backslash substitution in comments isn't part
- * of the formal spec, but test parse-15.47 and history
- * indicate that it has been the de facto rule. Don't
- * change it now.
- */
-
- TclParseBackslash(p, numBytes, &scanned, NULL);
- p += scanned;
- numBytes -= scanned;
- }
- } else {
p++;
numBytes--;
- if (p[-1] == '\n') {
+ if (numBytes == 0) {
break;
}
}
+ incomplete = (*p == '\n');
+ p++;
+ numBytes--;
}
parsePtr->commentSize = p - parsePtr->commentStart;
}
+ parsePtr->incomplete = incomplete;
return (p - src);
}
@@ -1213,7 +1145,7 @@ ParseTokens(
src++;
numBytes--;
- nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
+ nestedPtr = (Tcl_Parse *)TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
const char *curEnd;
@@ -1600,7 +1532,7 @@ Tcl_ParseVar(
{
Tcl_Obj *objPtr;
int code;
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
TclStackFree(interp, parsePtr);
@@ -2079,7 +2011,7 @@ TclSubstParse(
Tcl_Token *tokenPtr;
const char *lastTerm = parsePtr->term;
- Tcl_Parse *nestedPtr =
+ Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
while (TCL_OK ==
@@ -2221,7 +2153,7 @@ TclSubstTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2230,7 +2162,7 @@ TclSubstTokens(
Tcl_Obj *appendObj = NULL;
const char *append = NULL;
int appendByteLength = 0;
- char utfCharBytes[TCL_UTF_MAX] = "";
+ char utfCharBytes[4] = "";
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
@@ -2266,12 +2198,12 @@ TclSubstTokens(
if (result == 0) {
clPos = 0;
} else {
- Tcl_GetStringFromObj(result, &clPos);
+ TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = ckrealloc(clPosition,
+ clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
@@ -2464,7 +2396,7 @@ TclSubstTokens(
*----------------------------------------------------------------------
*/
-static inline int
+static int
CommandComplete(
const char *script, /* Script to check. */
int numBytes) /* Number of bytes in script. */
@@ -2542,7 +2474,7 @@ TclObjCommandComplete(
* check. */
{
int length;
- const char *script = Tcl_GetStringFromObj(objPtr, &length);
+ const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
diff --git a/generic/tclParse.h b/generic/tclParse.h
index 9247602..5f75c9a 100644
--- a/generic/tclParse.h
+++ b/generic/tclParse.h
@@ -12,6 +12,6 @@
#define TYPE_CLOSE_BRACK 0x20
#define TYPE_BRACE 0x40
-#define CHAR_TYPE(c) (tclCharTypeTable+128)[(unsigned char)(c)]
+#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)]
MODULE_SCOPE const char tclCharTypeTable[];
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 372a30d..87aed3a 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -5,7 +5,7 @@
* to represent and manipulate a general (virtual) filesystem entity in
* an efficient manner.
*
- * Copyright (c) 2003 Vince Darley.
+ * Copyright © 2003 Vince Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -36,7 +36,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp,
* internally.
*/
-static const Tcl_ObjType tclFsPathType = {
+static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -47,46 +47,21 @@ static const Tcl_ObjType tclFsPathType = {
/*
* struct FsPath --
*
- * Internal representation of a Tcl_Obj of "path" type. This can be used to
- * represent relative or absolute paths, and has certain optimisations when
- * used to represent paths which are already normalized and absolute.
- *
- * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular
- * reference to the container Tcl_Obj of this FsPath.
- *
- * There are two cases, with the first being the most common:
- *
- * (i) flags == 0, => Ordinary path.
- *
- * translatedPathPtr contains the translated path (which may be a circular
- * reference to the object itself). If it is NULL then the path is pure
- * normalized (and the normPathPtr will be a circular reference). cwdPtr is
- * null for an absolute path, and non-null for a relative path (unless the cwd
- * has never been set, in which case the cwdPtr may also be null for a
- * relative path).
- *
- * (ii) flags != 0, => Special path, see TclNewFSPathObj
- *
- * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir
- * and normPathPtr is the $tail.
- *
+ * Internal representation of a Tcl_Obj of fsPathType
*/
typedef struct FsPath {
- Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this
- * is NULL, then this is a pure normalized,
- * absolute path object, in which the parent
- * Tcl_Obj's string rep is already both
- * translated and normalized. */
- Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or
- * ~user sequences. If the Tcl_Obj containing
- * this FsPath is already normalized, this may
- * be a circular reference back to the
- * container. If that is NOT the case, we have
- * a refCount on the object. */
- Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points
- * to the cwd object used for this path. We
- * have a refCount on the object. */
+ Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags ==
+ * 0), this is NULL. Otherwise it is a path
+ * in which any ~user sequences have been
+ * translated away. */
+ Tcl_Obj *normPathPtr; /* If the path has been normalized (flags ==
+ * 0), this is an absolute path without ., ..
+ * or ~user components. Otherwise it is a
+ * path, possibly absolute, to normalize
+ * relative to cwdPtr. */
+ Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or
+ * normPathPtr exists and is absolute. */
int flags; /* Flags to describe interpretation - see
* below. */
ClientData nativePathPtr; /* Native representation of this path, which
@@ -110,9 +85,14 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
+#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \
+ } while (0)
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
@@ -135,17 +115,17 @@ typedef struct FsPath {
* pathPtr may have a refCount of zero, or may be a shared object.
*
* Results:
- * The result is returned in a Tcl_Obj with a refCount of 1, which is
- * therefore owned by the caller. It must be freed (with
- * Tcl_DecrRefCount) by the caller when no longer needed.
+ * The result is returned in a Tcl_Obj with a refCount already
+ * incremented, which gives the caller ownership of it. The caller must
+ * arrange for Tcl_DecRefCount to be called when the object is no-longer
+ * needed.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special note:
- * This code was originally based on code from Matt Newman and
- * Jean-Claude Wippler, but has since been totally rewritten by Vince
- * Darley to deal with symbolic links.
+ * Originally based on code from Matt Newman and Jean-Claude Wippler.
+ * Totally rewritten later by Vince Darley to handle symbolic links.
*
*---------------------------------------------------------------------------
*/
@@ -232,7 +212,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -258,7 +238,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -289,7 +269,7 @@ TclFSNormalizeAbsolutePath(
*/
const char *path =
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
while (--curLen >= 0) {
if (IsSeparatorOrNull(path[curLen])) {
@@ -304,7 +284,7 @@ TclFSNormalizeAbsolutePath(
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
@@ -317,7 +297,7 @@ TclFSNormalizeAbsolutePath(
} else {
retVal = linkObj;
}
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
@@ -334,7 +314,7 @@ TclFSNormalizeAbsolutePath(
}
}
} else {
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
@@ -405,7 +385,7 @@ TclFSNormalizeAbsolutePath(
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
int len;
- const char *path = Tcl_GetStringFromObj(retVal, &len);
+ const char *path = TclGetStringFromObj(retVal, &len);
if (len == 2 && path[0] != 0 && path[1] == ':') {
if (Tcl_IsShared(retVal)) {
@@ -564,7 +544,7 @@ TclPathPart(
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
@@ -580,7 +560,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -618,7 +598,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -647,7 +627,7 @@ TclPathPart(
const char *fileName, *extension;
int length;
- fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
+ fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
@@ -699,7 +679,7 @@ TclPathPart(
int length;
const char *fileName, *extension;
- fileName = Tcl_GetStringFromObj(pathPtr, &length);
+ fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
@@ -714,9 +694,8 @@ TclPathPart(
}
/*
- * The behaviour we want here is slightly different to the standard
* Tcl_FSSplitPath in the handling of home directories;
- * Tcl_FSSplitPath preserves the "~" while this code computes the
+ * Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
@@ -833,12 +812,12 @@ Tcl_FSJoinPath(
int objc;
Tcl_Obj **objv;
- if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) {
+ if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) {
return NULL;
}
elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
- TclListObjGetElements(NULL, listObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, listObj, &objc, &objv);
res = TclJoinPath(elements, objv, 0);
return res;
}
@@ -865,6 +844,7 @@ TclJoinPath(
if (elements == 2) {
Tcl_Obj *elt = objv[0];
+ Tcl_ObjInternalRep *eltIr = TclFetchInternalRep(elt, &fsPathType);
/*
* This is a special case where we can be much more efficient, where
@@ -875,10 +855,10 @@ TclJoinPath(
* could expand that in the future.
*
* Bugfix [a47641a0]. TclNewFSPathObj requires first argument
- * to be an absolute path. Added a check for that elt is absolute.
+ * to be an absolute path. Added a check to ensure that elt is absolute.
*/
- if ((elt->typePtr == &tclFsPathType)
+ if ((eltIr)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
Tcl_Obj *tailObj = objv[1];
@@ -891,7 +871,7 @@ TclJoinPath(
const char *str;
int len;
- str = Tcl_GetStringFromObj(tailObj, &len);
+ str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
@@ -962,7 +942,7 @@ TclJoinPath(
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
- strElt = Tcl_GetStringFromObj(elt, &strEltLen);
+ strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
/* if forceRelative - all paths excepting first one are relative */
type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
@@ -1058,10 +1038,8 @@ TclJoinPath(
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
- ptr = Tcl_GetStringFromObj(res, &length);
- } else {
- ptr = Tcl_GetStringFromObj(res, &length);
}
+ ptr = TclGetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the beginning of
@@ -1094,7 +1072,7 @@ TclJoinPath(
if (sep != NULL) {
separator = TclGetString(sep)[0];
- Tcl_DecrRefCount(sep);
+ TclDecrRefCount(sep);
}
/* Safety check in case the VFS driver caused sharing */
if (Tcl_IsShared(res)) {
@@ -1106,7 +1084,7 @@ TclJoinPath(
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
- Tcl_GetStringFromObj(res, &length);
+ TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
@@ -1172,39 +1150,16 @@ Tcl_FSConvertToPathType(
* path.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
return TCL_OK;
}
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
}
return SetFsPathFromAny(interp, pathPtr);
-
- /*
- * We used to have more complex code here:
- *
- * FsPath *fsPathPtr = PATHOBJ(pathPtr);
- * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
- * return TCL_OK;
- * } else {
- * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- * return TCL_OK;
- * } else {
- * if (pathPtr->bytes == NULL) {
- * UpdateStringOfFsPath(pathPtr);
- * }
- * FreeFsPathInternalRep(pathPtr);
- * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
- * }
- * }
- *
- * But we no longer believe this is necessary.
- */
}
/*
@@ -1319,7 +1274,7 @@ TclNewFSPathObj(
}
TclNewObj(pathPtr);
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
@@ -1336,9 +1291,7 @@ TclNewFSPathObj(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
- pathPtr->typePtr = &tclFsPathType;
- pathPtr->bytes = NULL;
- pathPtr->length = 0;
+ TclInvalidateStringRep(pathPtr);
/*
* Look for path components made up of only "."
@@ -1400,7 +1353,7 @@ AppendPath(
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
- bytes = Tcl_GetStringFromObj(tail, &numBytes);
+ bytes = TclGetStringFromObj(tail, &numBytes);
if (numBytes == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
@@ -1433,14 +1386,15 @@ AppendPath(
Tcl_Obj *
TclFSMakePathRelative(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* The path we have. */
Tcl_Obj *cwdPtr) /* Make it relative to this. */
{
int cwdLen, len;
const char *tempStr;
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
@@ -1459,7 +1413,7 @@ TclFSMakePathRelative(
* too little below, leading to wrong answers returned by glob.
*/
- tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
@@ -1479,7 +1433,7 @@ TclFSMakePathRelative(
}
break;
}
- tempStr = Tcl_GetStringFromObj(pathPtr, &len);
+ tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -1503,36 +1457,16 @@ TclFSMakePathRelative(
static int
MakePathFromNormalized(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
- /*
- * Free old representation
- */
-
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't find object string representation", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
- NULL);
- }
- return TCL_ERROR;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
@@ -1540,11 +1474,7 @@ MakePathFromNormalized(
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
@@ -1553,7 +1483,6 @@ MakePathFromNormalized(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1563,7 +1492,7 @@ MakePathFromNormalized(
*
* Tcl_FSNewNativePath --
*
- * This function performs the something like the reverse of the usual
+ * Performs the something like the reverse of the usual
* obj->path->nativerep conversions. If some code retrieves a path in
* native form (from, e.g. readlink or a native dialog), and that path is
* to be used at the Tcl level, then calling this function is an
@@ -1604,25 +1533,12 @@ Tcl_FSNewNativePath(
* safe.
*/
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- return NULL;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
- fsPathPtr = ckalloc(sizeof(FsPath));
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference, by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
@@ -1630,7 +1546,6 @@ Tcl_FSNewNativePath(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
@@ -1640,16 +1555,18 @@ Tcl_FSNewNativePath(
*
* Tcl_FSGetTranslatedPath --
*
- * This function attempts to extract the translated path from the given
+ * Attempts to extract the translated path from the given
* Tcl_Obj. If the translation succeeds (i.e. the object is a valid
- * path), then it is returned. Otherwise NULL will be returned, and an
- * error message may be left in the interpreter (if it is non-NULL)
+ * path), then it is returned. Otherwise NULL is returned and an
+ * error message may be left in the interpreter if it is not NULL.
*
* Results:
- * NULL or a valid Tcl_Obj pointer.
+ * A Tcl_Obj pointer or NULL.
*
* Side effects:
- * Only those of 'Tcl_FSConvertToPathType'
+ * pathPtr is converted to fsPathType if necessary.
+ *
+ * FsPath members are modified as needed.
*
*---------------------------------------------------------------------------
*/
@@ -1667,7 +1584,12 @@ Tcl_FSGetTranslatedPath(
}
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
- if (PATHFLAGS(pathPtr) != 0) {
+ if (PATHFLAGS(pathPtr) == 0) {
+ /*
+ * Path is already normalized
+ */
+ retObj = srcFsPathPtr->normPathPtr;
+ } else {
/*
* We lack a translated path result, but we have a directory
* (cwdPtr) and a tail (normPathPtr), and if we join the
@@ -1677,29 +1599,23 @@ Tcl_FSGetTranslatedPath(
Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
srcFsPathPtr->cwdPtr);
+ Tcl_ObjInternalRep *translatedCwdIrPtr;
+
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
- srcFsPathPtr->translatedPathPtr = retObj;
- if (translatedCwdPtr->typePtr == &tclFsPathType) {
+ Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj);
+ translatedCwdIrPtr = TclFetchInternalRep(translatedCwdPtr, &fsPathType);
+ if (translatedCwdIrPtr) {
srcFsPathPtr->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
- Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
- } else {
- /*
- * It is a pure absolute, normalized path object. This is
- * something like being a 'pure list'. The object's string,
- * translatedPath and normalizedPath are all identical.
- */
-
- retObj = srcFsPathPtr->normPathPtr;
}
} else {
/*
@@ -1743,8 +1659,8 @@ Tcl_FSGetTranslatedStringPath(
if (transPtr != NULL) {
int len;
- const char *orig = Tcl_GetStringFromObj(transPtr, &len);
- char *result = ckalloc(len+1);
+ const char *orig = TclGetStringFromObj(transPtr, &len);
+ char *result = (char *)ckalloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
@@ -1800,11 +1716,9 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
/* TODO: Figure out why this is needed. */
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
+ TclGetString(pathPtr);
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
@@ -1817,7 +1731,7 @@ Tcl_FSGetNormalizedPath(
* We now own a reference on both 'dir' and 'copy'
*/
- (void) Tcl_GetStringFromObj(dir, &cwdLen);
+ (void) TclGetStringFromObj(dir, &cwdLen);
/* Normalize the combined string. */
@@ -1854,7 +1768,7 @@ 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 == &fsPathType. 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
@@ -1869,10 +1783,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
@@ -1881,10 +1791,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
@@ -1896,10 +1802,8 @@ Tcl_FSGetNormalizedPath(
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
@@ -1910,7 +1814,7 @@ Tcl_FSGetNormalizedPath(
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
- (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
+ (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/*
@@ -1925,10 +1829,9 @@ Tcl_FSGetNormalizedPath(
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
- int pureNormalized = 1;
/*
- * Since normPathPtr is NULL, but this is a valid path object, we know
+ * Since normPathPtr is NULL but this is a valid path object, we know
* that the translatedPathPtr cannot be NULL.
*/
@@ -1975,7 +1878,6 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
- pureNormalized = 0;
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
@@ -1995,7 +1897,6 @@ Tcl_FSGetNormalizedPath(
if (absolutePath == NULL) {
return NULL;
}
- pureNormalized = 0;
#endif /* _WIN32 */
}
}
@@ -2004,35 +1905,12 @@ Tcl_FSGetNormalizedPath(
* Already has refCount incremented.
*/
+ if (fsPathPtr->normPathPtr) {
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ }
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
absolutePath);
- /*
- * Check if path is pure normalized (this can only be the case if it
- * is an absolute path).
- */
-
- if (pureNormalized) {
- 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.
- */
-
- TclDecrRefCount(fsPathPtr->normPathPtr);
-
- /*
- * We do *not* increment the refCount for this circular
- * reference.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
- }
- }
if (useThisCwd != NULL) {
/*
* We just need to free an object we allocated above for relative
@@ -2053,19 +1931,23 @@ Tcl_FSGetNormalizedPath(
*
* Tcl_FSGetInternalRep --
*
- * Extract the internal representation of a given path object, in the
- * given filesystem. If the path object belongs to a different
- * filesystem, we return NULL.
+ * Produces a native representation of a given path object in the given
+ * filesystem.
*
- * If the internal representation is currently NULL, we attempt to
- * generate it, by calling the filesystem's
- * 'Tcl_FSCreateInternalRepProc'.
+ * 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.
*
* Results:
- * NULL or a valid internal representation.
+ *
+ * The native handle for the path, or NULL if the path is not handled by
+ * the given filesystem
*
* Side effects:
- * An attempt may be made to convert the object.
+ *
+ * Tcl_FSCreateInternalRepProc if needed to produce the native
+ * handle, which is then stored in the internal representation of pathPtr.
*
*---------------------------------------------------------------------------
*/
@@ -2083,49 +1965,36 @@ Tcl_FSGetInternalRep(
srcFsPathPtr = PATHOBJ(pathPtr);
/*
- * We will only return the native representation for the caller's
- * filesystem. Otherwise we will simply return NULL. This means that there
- * must be a unique bi-directional mapping between paths and filesystems,
- * and that this mapping will not allow 'remapped' files -- files which
- * are in one filesystem but mapped into another. Another way of putting
- * this is that 'stacked' filesystems are not allowed. We recognise that
- * this is a potentially useful feature for the future.
+ * Currently there must be a unique bi-directional mapping between a path
+ * and a filesystem, and therefore there is no way to "remap" a file, i.e.,
+ * to map a file in one filesystem into another. Another way of putting
+ * this is that 'stacked' filesystems are not allowed. It could be useful
+ * in the future to redesign the system to allow that.
*
* Even something simple like a 'pass through' filesystem which logs all
* activity and passes the calls onto the native system would be nice, but
- * not easily achievable with the current implementation.
+ * not currently easily achievable.
*/
if (srcFsPathPtr->fsPtr == NULL) {
- /*
- * This only usually happens in wrappers like TclpStat which create a
- * string object and pass it to TclpObjStat. Code which calls the
- * Tcl_FS.. functions should always have a filesystem already set.
- * Whether this code path is legal or not depends on whether we decide
- * to allow external code to call the native filesystem directly. It
- * is at least safer to allow this sub-optimal routing.
- */
-
Tcl_FSGetFileSystemForPath(pathPtr);
- /*
- * If we fail through here, then the path is probably not a valid path
- * in the filesystsem, and is most likely to be a use of the empty
- * path "" via a direct call to one of the objectified interfaces
- * (e.g. from the Tcl testsuite).
- */
-
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->fsPtr == NULL) {
+ /*
+ * The path is probably not a valid path in the filesystsem, and is
+ * most likely to be a use of the empty path "" via a direct call
+ * to one of the objectified interfaces (e.g. from the Tcl
+ * testsuite).
+ */
return NULL;
}
}
/*
- * There is still one possibility we should consider; if the file belongs
- * to a different filesystem, perhaps it is actually linked through to a
- * file in our own filesystem which we do care about. The way we can check
- * for this is we ask what filesystem this path belongs to.
+ * If the file belongs to a different filesystem, perhaps it is actually
+ * linked through to a file in the given filesystem. Check this by
+ * inspecting the filesystem associated with the given path.
*/
if (fsPtr != srcFsPathPtr->fsPtr) {
@@ -2146,7 +2015,7 @@ Tcl_FSGetInternalRep(
return NULL;
}
- nativePathPtr = proc(pathPtr);
+ nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
@@ -2160,15 +2029,15 @@ Tcl_FSGetInternalRep(
*
* TclFSEnsureEpochOk --
*
- * This will ensure the pathPtr is up to date and can be converted into a
- * "path" type, and that we are able to generate a complete normalized
- * path which is used to determine the filesystem match.
+ * Ensure that the path is a valid path, and that it has a
+ * fsPathType internal representation that is not stale.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
- * An attempt may be made to convert the object.
+ * The internal representation of fsPtrPtr is converted to fsPathType if
+ * possible.
*
*---------------------------------------------------------------------------
*/
@@ -2180,37 +2049,31 @@ TclFSEnsureEpochOk(
{
FsPath *srcFsPathPtr;
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
srcFsPathPtr = PATHOBJ(pathPtr);
- /*
- * Check if the filesystem has changed in some way since this object's
- * internal representation was calculated.
- */
-
if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
/*
- * We have to discard the stale representation and recalculate it.
+ * The filesystem has changed in some way since the internal
+ * representation for this object was calculated. Discard the stale
+ * representation and recalculate it.
*/
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = PATHOBJ(pathPtr);
}
- /*
- * Check whether the object is already assigned to a fs.
- */
-
if (srcFsPathPtr->fsPtr != NULL) {
+ /*
+ * There is already a filesystem assigned to this path.
+ */
*fsPtrPtr = srcFsPathPtr->fsPtr;
}
return TCL_OK;
@@ -2244,7 +2107,7 @@ TclFSSetPathDetails(
* Make sure pathPtr is of the correct type.
*/
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasInternalRep(pathPtr, &fsPathType)) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
@@ -2318,11 +2181,12 @@ Tcl_FSEqualPaths(
*
* SetFsPathFromAny --
*
- * This function tries to convert the given Tcl_Obj to a valid Tcl path
- * type.
+ * Attempt to convert the internal representation of pathPtr to
+ * fsPathType.
*
- * The filename may begin with "~" (to indicate current user's home
- * directory) or "~<user>" (to indicate any user's home directory).
+ * A tilde ("~") character at the beginnig of the filename indicates the
+ * current user's home directory, and "~<user>" indicates a particular
+ * user's directory.
*
* Results:
* Standard Tcl error code.
@@ -2341,9 +2205,9 @@ SetFsPathFromAny(
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
- char *name;
+ const char *name;
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
@@ -2361,7 +2225,7 @@ SetFsPathFromAny(
* cmdAH.test exercise most of the code).
*/
- name = Tcl_GetStringFromObj(pathPtr, &len);
+ name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
@@ -2406,7 +2270,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&dirString);
} else {
/*
- * We have a user name '~user'
+ * There is a '~user'
*/
const char *expandedUser;
@@ -2431,7 +2295,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&userName);
}
- transPtr = TclDStringToObj(&temp);
+ transPtr = Tcl_DStringToObj(&temp);
if (split != len) {
/*
@@ -2449,7 +2313,7 @@ SetFsPathFromAny(
Tcl_Obj **objv;
Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);
- TclListObjGetElements(NULL, parts, &objc, &objv);
+ TclListObjGetElementsM(NULL, parts, &objc, &objv);
/*
* Skip '~'. It's replaced by its expansion.
@@ -2483,29 +2347,23 @@ SetFsPathFromAny(
* slashes on Windows, and will not contain any ~user sequences.
*/
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
- fsPathPtr->translatedPathPtr = transPtr;
- if (transPtr != pathPtr) {
- Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
- /* Redo translation when $env(HOME) changes */
- fsPathPtr->filesystemEpoch = TclFSEpoch();
+ if (transPtr == pathPtr) {
+ transPtr = Tcl_DuplicateObj(pathPtr);
+ fsPathPtr->filesystemEpoch = 0;
} else {
- fsPathPtr->filesystemEpoch = 0;
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
}
+ Tcl_IncrRefCount(transPtr);
+ fsPathPtr->translatedPathPtr = transPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
- /*
- * Free old representation before installing our new one.
- */
-
- TclFreeIntRep(pathPtr);
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -2528,6 +2386,7 @@ FreeFsPathInternalRep(
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
@@ -2540,7 +2399,6 @@ FreeFsPathInternalRep(
}
ckfree(fsPathPtr);
- pathPtr->typePtr = NULL;
}
static void
@@ -2549,28 +2407,18 @@ DupFsPathInternalRep(
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
- FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath));
+ FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
- if (srcFsPathPtr->translatedPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->translatedPathPtr = copyPtr;
- } else {
- copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
- if (copyFsPathPtr->translatedPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
- }
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ if (copyFsPathPtr->translatedPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
- if (srcFsPathPtr->normPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->normPathPtr = copyPtr;
- } else {
- copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
- if (copyFsPathPtr->normPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
- }
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
@@ -2596,8 +2444,6 @@ DupFsPathInternalRep(
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
-
- copyPtr->typePtr = &tclFsPathType;
}
/*
@@ -2629,11 +2475,15 @@ UpdateStringOfFsPath(
}
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
+ if (Tcl_IsShared(copy)) {
+ copy = Tcl_DuplicateObj(copy);
+ }
- pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
+ Tcl_IncrRefCount(copy);
+ /* Steal copy's string rep */
+ pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
- copy->bytes = tclEmptyStringRep;
- copy->length = 0;
+ TclInitStringRep(copy, NULL, 0);
TclDecrRefCount(copy);
}
@@ -2661,7 +2511,7 @@ UpdateStringOfFsPath(
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(ClientData *))
{
/*
* A special case is required to handle the empty path "". This is a valid
@@ -2670,7 +2520,7 @@ TclNativePathInFilesystem(
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/*
* We reject the empty path "".
@@ -2685,13 +2535,13 @@ TclNativePathInFilesystem(
} else {
/*
* It is somewhat unusual to reach this code path without the object
- * being of tclFsPathType. However, we do our best to deal with the
+ * being of fsPathType. However, we do our best to deal with the
* situation.
*/
int len;
- (void) Tcl_GetStringFromObj(pathPtr, &len);
+ (void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
@@ -2709,6 +2559,253 @@ TclNativePathInFilesystem(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * MakeTildeRelativePath --
+ *
+ * Returns a path relative to the home directory of a user.
+ * Note there is a difference between not specifying a user and
+ * explicitly specifying the current user. This mimics Tcl8's tilde
+ * expansion.
+ *
+ * The subPath argument is joined to the expanded home directory
+ * as in Tcl_JoinPath. This means if it is not relative, it will
+ * returned as the result with the home directory only checked
+ * for user name validity.
+ *
+ * Results:
+ * Returns TCL_OK on success with home directory path in *dsPtr
+ * and TCL_ERROR on failure with error message in interp if non-NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+MakeTildeRelativePath(
+ Tcl_Interp *interp, /* May be NULL. Only used for error messages */
+ const char *user, /* User name. NULL -> current user */
+ const char *subPath, /* Rest of path. May be NULL */
+ Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be
+ freed on success */
+{
+ const char *dir;
+ Tcl_DString dirString;
+
+ Tcl_DStringInit(dsPtr);
+ Tcl_DStringInit(&dirString);
+
+ if (user == NULL || user[0] == 0) {
+ /* No user name specified -> current user */
+
+ dir = TclGetEnv("HOME", &dirString);
+ if (dir == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't find HOME environment variable to"
+ " expand path", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
+ "HOMELESS", NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ /* User name specified - ~user */
+ dir = TclpGetUserHome(user, &dirString);
+ if (dir == NULL) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", user));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
+ NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+ if (subPath) {
+ const char *parts[2];
+ parts[0] = dir;
+ parts[1] = subPath;
+ Tcl_JoinPath(2, parts, dsPtr);
+ } else {
+ Tcl_JoinPath(1, &dir, dsPtr);
+ }
+
+ Tcl_DStringFree(&dirString);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetHomeDirObj --
+ *
+ * Wrapper around MakeTildeRelativePath. See that function.
+ *
+ * Results:
+ * Returns a Tcl_Obj containing the home directory of a user
+ * or NULL on failure with error message in interp if non-NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclGetHomeDirObj(
+ Tcl_Interp *interp, /* May be NULL. Only used for error messages */
+ const char *user) /* User name. NULL -> current user */
+{
+ Tcl_DString dirString;
+
+ if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_DStringToObj(&dirString);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResolveTildePath --
+ *
+ * If the passed path is begins with a tilde, does tilde resolution
+ * and returns a Tcl_Obj containing the resolved path. If the tilde
+ * component cannot be resolved, returns NULL. If the path does not
+ * begin with a tilde, returns as is.
+ *
+ * Results:
+ * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj
+ * with ref count 0 or that pathObj that was passed in without its
+ * ref count modified.
+ * Returns NULL if the path begins with a ~ that cannot be resolved
+ * and stores an error message in interp if non-NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclResolveTildePath(
+ Tcl_Interp *interp, /* May be NULL. Only used for error messages */
+ Tcl_Obj *pathObj)
+{
+ const char *path;
+ int len;
+ int split;
+ Tcl_DString resolvedPath;
+
+ path = Tcl_GetStringFromObj(pathObj, &len);
+ if (path[0] != '~') {
+ return pathObj;
+ }
+
+ /*
+ * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
+ * split becomes value 1 for '~/...' as well as for '~'. Note on
+ * Windows FindSplitPos will implicitly check for '\' as separator
+ * in addition to what is passed.
+ */
+ split = FindSplitPos(path, '/');
+
+ if (split == 1) {
+ /* No user name specified -> current user */
+ if (MakeTildeRelativePath(
+ interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath)
+ != TCL_OK) {
+ return NULL;
+ }
+ } else {
+ /* User name specified - ~user */
+ const char *expandedUser;
+ Tcl_DString userName;
+
+ Tcl_DStringInit(&userName);
+ Tcl_DStringAppend(&userName, path+1, split-1);
+ expandedUser = Tcl_DStringValue(&userName);
+
+ /* path[split] is / or \0 */
+ if (MakeTildeRelativePath(interp,
+ expandedUser,
+ path[split] ? &path[split+1] : NULL,
+ &resolvedPath)
+ != TCL_OK) {
+ Tcl_DStringFree(&userName);
+ return NULL;
+ }
+ Tcl_DStringFree(&userName);
+ }
+ return Tcl_DStringToObj(&resolvedPath);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResolveTildePathList --
+ *
+ * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing
+ * the paths with any ~-prefixed paths resolved.
+ *
+ * Empty strings and ~-prefixed paths that cannot be resolved are
+ * removed from the returned list.
+ *
+ * The trailing components of the path are returned verbatim. No
+ * processing is done on them. Moreover, no assumptions should be
+ * made about the separators in the returned path. They may be /
+ * or native. Appropriate path manipulations functions should be
+ * used by caller if desired.
+ *
+ * Results:
+ * Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with
+ * reference count 0 or the original passed-in Tcl_Obj if no paths needed
+ * resolution. A NULL is returned if the passed in value is not a list
+ * or was NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclResolveTildePathList(
+ Tcl_Obj *pathsObj)
+{
+ Tcl_Obj **objv;
+ int objc;
+ int i;
+ Tcl_Obj *resolvedPaths;
+ const char *path;
+
+ if (pathsObj == NULL) {
+ return NULL;
+ }
+ if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {
+ return NULL; /* Not a list */
+ }
+
+ /*
+ * Figure out if any paths need resolving to avoid unnecessary allocations.
+ */
+ for (i = 0; i < objc; ++i) {
+ path = Tcl_GetString(objv[i]);
+ if (path[0] == '~') {
+ break; /* At least one path needs resolution */
+ }
+ }
+ if (i == objc) {
+ return pathsObj; /* No paths needed to be resolved */
+ }
+
+ resolvedPaths = Tcl_NewListObj(objc, NULL);
+ for (i = 0; i < objc; ++i) {
+ Tcl_Obj *resolvedPath;
+ path = Tcl_GetString(objv[i]);
+ if (path[0] == 0) {
+ continue; /* Skip empty strings */
+ }
+ resolvedPath = TclResolveTildePath(NULL, objv[i]);
+ if (resolvedPath) {
+ /* Paths that cannot be resolved are skipped */
+ Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath);
+ }
+ }
+
+ return resolvedPaths;
+}
+
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index f5c82f1..699d559 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -4,7 +4,7 @@
* This file contains the generic portion of the command channel driver
* as well as various utility routines used in managing subprocesses.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec,
static TclFile
FileForRedirect(
- Tcl_Interp *interp, /* Intepreter to use for error reporting. */
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *spec, /* Points to character just after redirection
* character. */
int atOK, /* Non-zero means that '@' notation can be
@@ -188,7 +188,7 @@ Tcl_DetachPids(
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
- detPtr = ckalloc(sizeof(Detached));
+ detPtr = (Detached *)ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
@@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void)
{
Detached *detPtr;
Detached *nextPtr, *prevPtr;
- int status;
- Tcl_Pid pid;
+ int status, code;
Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
- pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
- if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
+ status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
+ if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
+ && code != ECHILD)) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
continue;
@@ -277,38 +277,21 @@ TclCleanupChildren(
{
int result = TCL_OK;
int i, abnormalExit, anyErrorInfo;
- Tcl_Pid pid;
- int waitStatus;
- const char *msg;
- unsigned long resolvedPid;
+ TclProcessWaitStatus waitStatus;
+ int code;
+ Tcl_Obj *msg, *error;
abnormalExit = 0;
for (i = 0; i < numPids; i++) {
- /*
- * We need to get the resolved pid before we wait on it as the windows
- * implementation of Tcl_WaitPid deletes the information such that any
- * following calls to TclpGetPid fail.
- */
-
- resolvedPid = TclpGetPid(pidPtr[i]);
- pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
- if (pid == (Tcl_Pid) -1) {
+ waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
+ if (waitStatus == TCL_PROCESS_ERROR) {
result = TCL_ERROR;
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_SetObjResult(interp, Tcl_ObjPrintf(
- "error waiting for process to exit: %s", msg));
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
continue;
}
@@ -319,39 +302,19 @@ TclCleanupChildren(
* removed).
*/
- if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
- char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
-
+ if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
result = TCL_ERROR;
- sprintf(msg1, "%lu", resolvedPid);
- if (WIFEXITED(waitStatus)) {
+ if (waitStatus == TCL_PROCESS_EXITED) {
if (interp != NULL) {
- sprintf(msg2, "%u", WEXITSTATUS(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
+ Tcl_SetObjErrorCode(interp, error);
}
abnormalExit = 1;
} else if (interp != NULL) {
- const char *p;
-
- if (WIFSIGNALED(waitStatus)) {
- p = Tcl_SignalMsg(WTERMSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
- Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child killed: %s\n", p));
- } else if (WIFSTOPPED(waitStatus)) {
- p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
- Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child suspended: %s\n", p));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "child wait status didn't make sense\n", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "ODDWAITRESULT", msg1, NULL);
- }
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
}
}
@@ -370,7 +333,7 @@ TclCleanupChildren(
int count;
Tcl_Obj *objPtr;
- Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
+ Tcl_Seek(errorChan, 0, SEEK_SET);
TclNewObj(objPtr);
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
@@ -861,7 +824,7 @@ TclCreatePipeline(
*/
Tcl_ReapDetachedProcs();
- pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid));
+ pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
@@ -936,6 +899,7 @@ TclCreatePipeline(
pidPtr[numPids] = pid;
numPids++;
+ TclProcessCreated(pid);
/*
* Close off our copies of file descriptors that were set up for this
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 35ec1a3..7866158 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -4,8 +4,8 @@
* This file implements package and version control for Tcl via the
* "package" command and a few C APIs.
*
- * Copyright (c) 1996 Sun Microsystems, Inc.
- * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 1996 Sun Microsystems, Inc.
+ * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,10 @@
#include "tclInt.h"
+MODULE_SCOPE char *tclEmptyStringRep;
+
+char *tclEmptyStringRep = &tclEmptyString;
+
/*
* Each invocation of the "package ifneeded" command creates a structure of
* the following type, which is used to load the package into the interpreter
@@ -28,10 +32,24 @@ typedef struct PkgAvail {
char *script; /* Script to invoke to provide this version of
* the package. Malloc'ed and protected by
* Tcl_Preserve and Tcl_Release. */
+ char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being
+ * initialized. */
+ char name[TCLFLEXARRAY];
+} PkgName;
+
+typedef struct PkgFiles {
+ PkgName *names; /* Package names being initialized. Must be
+ * first field. */
+ Tcl_HashTable table; /* Table which contains files for each
+ * package. */
+} PkgFiles;
+
/*
* For each package that is known in any way to an interpreter, there is one
* record of the following type. These records are stored in the
@@ -47,7 +65,7 @@ typedef struct Package {
} Package;
typedef struct Require {
- void * clientDataPtr;
+ void *clientDataPtr;
const char *name;
Package *pkgPtr;
char *versionToProvide;
@@ -93,10 +111,10 @@ static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int
*/
#define DupBlock(v,s,len) \
- ((v) = ckalloc(len), memcpy((v),(s),(len)))
+ ((v) = (char *)ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
- unsigned local__len = (unsigned) (strlen(s) + 1); \
+ size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
@@ -205,6 +223,78 @@ Tcl_PkgProvideEx(
*----------------------------------------------------------------------
*/
+static void
+PkgFilesCleanupProc(
+ ClientData clientData,
+ TCL_UNUSED(Tcl_Interp *))
+{
+ PkgFiles *pkgFiles = (PkgFiles *) clientData;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *entry;
+
+ while (pkgFiles->names) {
+ PkgName *name = pkgFiles->names;
+
+ pkgFiles->names = name->nextPtr;
+ ckfree(name);
+ }
+ entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
+ while (entry) {
+ Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
+
+ Tcl_DecrRefCount(obj);
+ entry = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&pkgFiles->table);
+ ckfree(pkgFiles);
+ return;
+}
+
+void *
+TclInitPkgFiles(
+ Tcl_Interp *interp)
+{
+ /*
+ * If assocdata "tclPkgFiles" doesn't exist yet, create it.
+ */
+
+ PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+
+ if (!pkgFiles) {
+ pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles));
+ pkgFiles->names = NULL;
+ Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
+ }
+ return pkgFiles;
+}
+
+void
+TclPkgFileSeen(
+ Tcl_Interp *interp,
+ const char *fileName)
+{
+ PkgFiles *pkgFiles = (PkgFiles *)
+ Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+
+ if (pkgFiles && pkgFiles->names) {
+ const char *name = pkgFiles->names->name;
+ Tcl_HashTable *table = &pkgFiles->table;
+ int isNew;
+ Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew);
+ Tcl_Obj *list;
+
+ if (isNew) {
+ TclNewObj(list);
+ Tcl_SetHashValue(entry, list);
+ Tcl_IncrRefCount(list);
+ } else {
+ list = (Tcl_Obj *)Tcl_GetHashValue(entry);
+ }
+ Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
+ }
+}
+
#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
@@ -274,12 +364,12 @@ Tcl_PkgRequireEx(
*
* Second, how does this work? If we reach this point, then the global
* variable tclEmptyStringRep has the value NULL. Compare that with
- * the definition of tclEmptyStringRep near the top of the file
- * generic/tclObj.c. It clearly should not have the value NULL; it
- * should point to the char tclEmptyString. If we see it having the
- * value NULL, then somehow we are seeing a Tcl library that isn't
- * completely initialized, and that's an indicator for the error
- * condition described above. (Further explanation is welcome.)
+ * the definition of tclEmptyStringRep near the top of this file. It
+ * clearly should not have the value NULL; it should point to the char
+ * tclEmptyString. If we see it having the value NULL, then somehow we
+ * are seeing a Tcl library that isn't completely initialized, and
+ * that's an indicator for the error condition described above.
+ * (Further explanation is welcome.)
*
* Third, so what do we do about it? This situation indicates the
* package we just loaded wasn't properly compiled to be stub-enabled,
@@ -291,18 +381,11 @@ Tcl_PkgRequireEx(
* After all, two Tcl libraries can't be a good thing!)
*
* Trouble is that's going to be tricky. We're now using a Tcl library
- * that's not fully initialized. In particular, it doesn't have a
- * proper value for tclEmptyStringRep. The Tcl_Obj system heavily
- * depends on the value of tclEmptyStringRep and all of Tcl depends
- * (increasingly) on the Tcl_Obj system, we need to correct that flaw
- * before making the calls to set the interpreter result to the error
- * message. That's the only flaw corrected; other problems with
- * initialization of the Tcl library are not remedied, so be very
- * careful about adding any other calls here without checking how they
- * behave when initialization is incomplete.
+ * that's not fully initialized. Functions in it may not work
+ * reliably, so be very careful about adding any other calls here
+ * without checking how they behave when initialization is incomplete.
*/
- tclEmptyStringRep = &tclEmptyString;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Cannot load package \"%s\" in standalone executable:"
" This package is not compiled with stub support", name));
@@ -350,9 +433,11 @@ Tcl_PkgRequireProc(
void *clientDataPtr)
{
RequireProcArgs args;
+
args.name = name;
args.clientDataPtr = clientDataPtr;
- return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv);
+ return Tcl_NRCallObjProc(interp,
+ TclNRPkgRequireProc, (void *) &args, reqc, reqv);
}
static int
@@ -360,79 +445,117 @@ TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
- Tcl_Obj *const reqv[]) {
- RequireProcArgs *args = clientData;
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr);
+ Tcl_Obj *const reqv[])
+{
+ RequireProcArgs *args = (RequireProcArgs *)clientData;
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
+ args->clientDataPtr);
return TCL_OK;
}
static int
-PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result)
+PkgRequireCore(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
{
- const char *name = data[0];
+ const char *name = (const char *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj *const *reqv = data[2];
+ Tcl_Obj **reqv = (Tcl_Obj **)data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
+
if (code != TCL_OK) {
return code;
}
- reqPtr = ckalloc(sizeof(Require));
+ reqPtr = (Require *)ckalloc(sizeof(Require));
Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
reqPtr->clientDataPtr = data[3];
reqPtr->name = name;
reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
- Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1);
+ Tcl_NRAddCallback(interp,
+ SelectPackage, reqPtr, INT2PTR(reqc), reqv,
+ (void *)PkgRequireCoreStep1);
} else {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL);
}
return TCL_OK;
}
static int
-PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) {
+PkgRequireCoreStep1(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
Tcl_DString command;
char *script;
- Require *reqPtr = data[0];
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name /* Name of desired package. */;
- if (reqPtr->pkgPtr->version == NULL) {
- /*
- * The package is not in the database. If there is a "package unknown"
- * command, invoke it.
- */
- script = ((Interp *) interp)->packageUnknown;
- if (script == NULL) {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
- } else {
- Tcl_DStringInit(&command);
- Tcl_DStringAppend(&command, script, -1);
- Tcl_DStringAppendElement(&command, name);
- AddRequirementsToDString(&command, reqc, reqv);
-
- Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
- Tcl_NREvalObj(interp,
- Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)),
- TCL_EVAL_GLOBAL
- );
- Tcl_DStringFree(&command);
- }
- return TCL_OK;
- } else {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ /*
+ * If we've got the package in the DB already, go on to actually loading
+ * it.
+ */
+
+ if (reqPtr->pkgPtr->version != NULL) {
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ return TCL_OK;
}
+
+ /*
+ * The package is not in the database. If there is a "package unknown"
+ * command, invoke it.
+ */
+
+ script = ((Interp *) interp)->packageUnknown;
+ if (script == NULL) {
+ /*
+ * No package unknown script. Move on to finalizing.
+ */
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ return TCL_OK;
+ }
+
+ /*
+ * Invoke the "package unknown" script synchronously.
+ */
+
+ Tcl_DStringInit(&command);
+ Tcl_DStringAppend(&command, script, -1);
+ Tcl_DStringAppendElement(&command, name);
+ AddRequirementsToDString(&command, reqc, reqv);
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
+ Tcl_NREvalObj(interp,
+ Tcl_NewStringObj(Tcl_DStringValue(&command),
+ Tcl_DStringLength(&command)),
+ TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&command);
return TCL_OK;
}
static int
-PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+PkgRequireCoreStep2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
- const char *name = reqPtr->name /* Name of desired package. */;
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
+ const char *name = reqPtr->name; /* Name of desired package. */
+
if ((result != TCL_OK) && (result != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", result));
@@ -445,20 +568,31 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
return result;
}
Tcl_ResetResult(interp);
- /* pkgPtr may now be invalid, so refresh it. */
+
+ /*
+ * pkgPtr may now be invalid, so refresh it.
+ */
+
reqPtr->pkgPtr = FindPackage(interp, name);
- Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal);
+ Tcl_NRAddCallback(interp,
+ SelectPackage, reqPtr, INT2PTR(reqc), reqv,
+ (void *)PkgRequireCoreFinal);
return TCL_OK;
}
static int
-PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+PkgRequireCoreFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]), satisfies;
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
- const char *name = reqPtr->name /* Name of desired package. */;
+ const char *name = reqPtr->name; /* Name of desired package. */
+
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
@@ -499,21 +633,28 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
}
static int
-PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+PkgRequireCoreCleanup(
+ ClientData data[],
+ TCL_UNUSED(Tcl_Interp *),
+ int result)
+{
ckfree(data[0]);
return result;
}
-
static int
-SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
+SelectPackage(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
- Require *reqPtr = data[0];
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
@@ -534,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
/*
- * The package isn't yet present. Search the list of available
- * versions and invoke the script for the best available version. We
- * are actually locating the best, and the best stable version. One of
- * them is then chosen based on the selection mode.
+ * The package isn't yet present. Search the list of available versions
+ * and invoke the script for the best available version. We are actually
+ * locating the best, and the best stable version. One of them is then
+ * chosen based on the selection mode.
*/
bestPtr = NULL;
@@ -550,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/*
- * The provided version number has invalid syntax. This
- * should not happen. This should have been caught by the
- * 'package ifneeded' registering the package.
+ * The provided version number has invalid syntax. This should not
+ * happen. This should have been caught by the 'package ifneeded'
+ * registering the package.
*/
continue;
}
- /* Check satisfaction of requirements before considering the current version further. */
+ /*
+ * Check satisfaction of requirements before considering the current
+ * version further.
+ */
+
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
@@ -580,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
* The version of the package sought is better than the
* currently selected version.
*/
+
ckfree(bestVersion);
bestVersion = NULL;
goto newbest;
}
} else {
newbest:
- /* We have found a version which is better than our max. */
+ /*
+ * We have found a version which is better than our max.
+ */
bestPtr = availPtr;
CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
@@ -607,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
if (res > 0) {
/*
- * This stable version of the package sought is better
- * than the currently selected stable version.
+ * This stable version of the package sought is better than
+ * the currently selected stable version.
*/
+
ckfree(bestStableVersion);
bestStableVersion = NULL;
goto newstable;
}
} else {
newstable:
- /* We have found a stable version which is better than our max stable. */
+ /*
+ * We have found a stable version which is better than our max
+ * stable.
+ */
+
bestStablePtr = availPtr;
- CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
+ CheckVersionAndConvert(interp, bestStablePtr->version,
+ &bestStableVersion, NULL);
}
ckfree(availVersion);
@@ -640,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
/*
- * Now choose a version among the two best. For 'latest' we simply
- * take (actually keep) the best. For 'stable' we take the best
- * stable, if there is any, or the best if there is nothing stable.
+ * Now choose a version among the two best. For 'latest' we simply take
+ * (actually keep) the best. For 'stable' we take the best stable, if
+ * there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
@@ -651,34 +805,67 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
if (bestPtr == NULL) {
- Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
} else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
- * script itself from deletion and (b) don't assume that bestPtr
- * will still exist when the script completes.
+ * script itself from deletion and (b) don't assume that bestPtr will
+ * still exist when the script completes.
*/
char *versionToProvide = bestPtr->version;
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
- pkgPtr->clientData = versionToProvide;
Tcl_Preserve(versionToProvide);
+ pkgPtr->clientData = versionToProvide;
+
+ pkgFiles = (PkgFiles *)TclInitPkgFiles(interp);
+
+ /*
+ * Push "ifneeded" package name in "tclPkgFiles" assocdata.
+ */
+
+ pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name));
+ pkgName->nextPtr = pkgFiles->names;
+ strcpy(pkgName->name, name);
+ pkgFiles->names = pkgName;
+ if (bestPtr->pkgIndex) {
+ TclPkgFileSeen(interp, bestPtr->pkgIndex);
+ }
reqPtr->versionToProvide = versionToProvide;
- Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]);
- Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL);
+ Tcl_NRAddCallback(interp,
+ SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
+ data[3]);
+ Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1),
+ TCL_EVAL_GLOBAL);
}
return TCL_OK;
}
static int
-SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+SelectPackageFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
+ /*
+ * Pop the "ifneeded" package name from "tclPkgFiles" assocdata
+ */
+
+ PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ PkgName *pkgName = pkgFiles->names;
+ pkgFiles->names = pkgName->nextPtr;
+ ckfree(pkgName);
+
reqPtr->pkgPtr = FindPackage(interp, name);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -739,14 +926,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
if (result != TCL_OK) {
/*
- * Take a non-TCL_OK code from the script as an indication the
- * package wasn't loaded properly, so the package system
- * should not remember an improper load.
+ * Take a non-TCL_OK code from the script as an indication the package
+ * wasn't loaded properly, so the package system should not remember
+ * an improper load.
*
- * This is consistent with our returning NULL. If we're not
- * willing to tell our caller we got a particular version, we
- * shouldn't store that version for telling future callers
- * either.
+ * This is consistent with our returning NULL. If we're not willing to
+ * tell our caller we got a particular version, we shouldn't store
+ * that version for telling future callers either.
*/
if (reqPtr->pkgPtr->version != NULL) {
@@ -757,7 +943,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
return result;
}
- Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
@@ -818,7 +1005,7 @@ Tcl_PkgPresentEx(
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
/*
* At this point we know that the package is present. Make sure
@@ -866,31 +1053,30 @@ Tcl_PkgPresentEx(
*/
int
Tcl_PackageObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
- /* ARGSUSED */
int
TclNRPackageObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
- "forget", "ifneeded", "names", "prefer", "present",
- "provide", "require", "unknown", "vcompare", "versions",
- "vsatisfies", NULL
+ "files", "forget", "ifneeded", "names", "prefer",
+ "present", "provide", "require", "unknown", "vcompare",
+ "versions", "vsatisfies", NULL
};
- enum pkgOptions {
- PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT,
- PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
- PKG_VSATISFIES
+ enum pkgOptionsEnum {
+ PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER,
+ PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
+ PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, newobjc, satisfies;
@@ -913,17 +1099,45 @@ TclNRPackageObjCmd(
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum pkgOptions) optionIndex) {
+ switch ((enum pkgOptionsEnum) optionIndex) {
+ case PKG_FILES: {
+ PkgFiles *pkgFiles;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package");
+ return TCL_ERROR;
+ }
+ pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ if (pkgFiles) {
+ Tcl_HashEntry *entry =
+ Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
+ if (entry) {
+ Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
+ }
+ }
+ break;
+ }
case PKG_FORGET: {
const char *keyString;
+ PkgFiles *pkgFiles = (PkgFiles *)
+ Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
+ if (pkgFiles) {
+ hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
+ if (hPtr) {
+ Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ Tcl_DecrRefCount(obj);
+ }
+ }
+
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
@@ -933,6 +1147,10 @@ TclNRPackageObjCmd(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -958,11 +1176,11 @@ TclNRPackageObjCmd(
ckfree(argv3i);
return TCL_OK;
}
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
- argv3 = Tcl_GetStringFromObj(objv[3], &length);
+ argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
@@ -975,7 +1193,7 @@ TclNRPackageObjCmd(
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
- if (res == 0){
+ if (res == 0) {
if (objc == 4) {
ckfree(argv3i);
Tcl_SetObjResult(interp,
@@ -983,6 +1201,10 @@ TclNRPackageObjCmd(
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
break;
}
}
@@ -992,8 +1214,9 @@ TclNRPackageObjCmd(
return TCL_OK;
}
if (availPtr == NULL) {
- availPtr = ckalloc(sizeof(PkgAvail));
- DupBlock(availPtr->version, argv3, (unsigned) length + 1);
+ availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail));
+ availPtr->pkgIndex = NULL;
+ DupBlock(availPtr->version, argv3, length + 1);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
@@ -1003,8 +1226,12 @@ TclNRPackageObjCmd(
prevPtr->nextPtr = availPtr;
}
}
- argv4 = Tcl_GetStringFromObj(objv[4], &length);
- DupBlock(availPtr->script, argv4, (unsigned) length + 1);
+ if (iPtr->scriptFile) {
+ argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
+ DupBlock(availPtr->pkgIndex, argv4, length + 1);
+ }
+ argv4 = TclGetStringFromObj(objv[4], &length);
+ DupBlock(availPtr->script, argv4, length + 1);
break;
}
case PKG_NAMES:
@@ -1018,10 +1245,10 @@ TclNRPackageObjCmd(
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
- Tcl_GetHashKey(tablePtr, hPtr), -1));
+ (char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, resultObj);
@@ -1047,7 +1274,7 @@ TclNRPackageObjCmd(
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
goto require;
}
@@ -1082,7 +1309,7 @@ TclNRPackageObjCmd(
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp, pkgPtr->version);
}
@@ -1132,33 +1359,39 @@ TclNRPackageObjCmd(
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_ListObjAppendElement(interp, objvListPtr, ov);
- TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
+ TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL);
+ Tcl_NRAddCallback(interp,
+ TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
+ newObjvPtr, NULL);
return TCL_OK;
} else {
Tcl_Obj *const *newobjv = objv + 3;
- newobjc = objc - 3;
- if (CheckAllRequirements(interp, objc - 3, objv + 3) != TCL_OK) {
+ newobjc = objc - 3;
+ if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_IncrRefCount(objv[2]);
for (i = 0; i < newobjc; i++) {
-
/*
* Tcl_Obj structures may have come from another interpreter,
* so duplicate them.
*/
- Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i]));
+ Tcl_ListObjAppendElement(interp, objvListPtr,
+ Tcl_DuplicateObj(newobjv[i]));
}
- TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
+ TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr);
+ Tcl_NRAddCallback(interp,
+ TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
+ newObjvPtr, NULL);
return TCL_OK;
}
break;
@@ -1174,11 +1407,11 @@ TclNRPackageObjCmd(
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
- argv2 = Tcl_GetStringFromObj(objv[2], &length);
+ argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
- DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1);
+ DupBlock(iPtr->packageUnknown, argv2, length+1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
@@ -1248,7 +1481,7 @@ TclNRPackageObjCmd(
*/
Tcl_SetObjResult(interp,
- Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
+ Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL)));
ckfree(iva);
ckfree(ivb);
break;
@@ -1263,7 +1496,7 @@ TclNRPackageObjCmd(
argv2 = TclGetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -1302,9 +1535,13 @@ TclNRPackageObjCmd(
}
static int
-TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) {
- TclDecrRefCount((Tcl_Obj *)data[0]);
- TclDecrRefCount((Tcl_Obj *)data[1]);
+TclNRPackageObjCmdCleanup(
+ ClientData data[],
+ TCL_UNUSED(Tcl_Interp *),
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
@@ -1338,13 +1575,13 @@ FindPackage(
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
- pkgPtr = ckalloc(sizeof(Package));
+ pkgPtr = (Package *)ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
}
return pkgPtr;
}
@@ -1368,7 +1605,7 @@ FindPackage(
void
TclFreePackageInfo(
- Interp *iPtr) /* Interpereter that is being deleted. */
+ Interp *iPtr) /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
@@ -1377,7 +1614,7 @@ TclFreePackageInfo(
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
@@ -1386,6 +1623,10 @@ TclFreePackageInfo(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -1432,7 +1673,7 @@ CheckVersionAndConvert(
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
- char *ibuf = ckalloc(4 + 4*strlen(string));
+ char *ibuf = (char *)ckalloc(4 + 4*strlen(string));
char *ip = ibuf;
/*
@@ -1455,7 +1696,7 @@ CheckVersionAndConvert(
*ip++ = *p;
- for (prevChar = *p, p++; *p != 0; p++) {
+ for (prevChar = *p, p++; (*p != 0) && (*p != '+'); p++) {
if (!isdigit(UCHAR(*p)) && /* INTL: digit */
((*p!='.' && *p!='a' && *p!='b') ||
((hasunstable && (*p=='a' || *p=='b')) ||
@@ -1759,10 +2000,10 @@ CheckRequirement(
char *dash = NULL, *buf;
- dash = strchr(string, '-');
+ dash = strchr(string, '+') ? NULL : (char *)strchr(string, '-');
if (dash == NULL) {
/*
- * No dash found, has to be a simple version.
+ * '+' found or no dash found: has to be a simple version.
*/
return CheckVersionAndConvert(interp, string, NULL, NULL);
@@ -1830,7 +2071,7 @@ AddRequirementsToResult(
int i, length;
for (i = 0; i < reqc; i++) {
- const char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ const char *v = TclGetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
@@ -1947,7 +2188,7 @@ RequirementSatisfied(
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
- dash = strchr(req, '-');
+ dash = (char *)strchr(req, '-');
if (dash == NULL) {
/*
* No dash found, is a simple version, fallback to regular check. The
@@ -2043,7 +2284,7 @@ Tcl_PkgInitStubsCheck(
{
const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
- if (exact && actualVersion) {
+ if ((exact&1) && actualVersion) {
const char *p = version;
int count = 0;
diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c
index 727e872..a0dae51 100644
--- a/generic/tclPkgConfig.c
+++ b/generic/tclPkgConfig.c
@@ -2,9 +2,9 @@
* tclPkgConfig.c --
*
* This file contains the configuration information to embed into the tcl
- * binary library.
+ * library.
*
- * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -36,11 +36,7 @@
#include "tclInt.h"
#ifndef TCL_CFGVAL_ENCODING
-# ifdef _WIN32
-# define TCL_CFGVAL_ENCODING "cp1252"
-# else
-# define TCL_CFGVAL_ENCODING "iso8859-1"
-# endif
+# define TCL_CFGVAL_ENCODING "utf-8"
#endif
/*
@@ -48,7 +44,7 @@
* configuration information.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
# define CFG_THREADED "1"
#else
# define CFG_THREADED "0"
@@ -97,6 +93,7 @@
#endif
static Tcl_Config const cfg[] = {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"debug", CFG_DEBUG},
{"threaded", CFG_THREADED},
{"profiled", CFG_PROFILED},
@@ -105,6 +102,7 @@ static Tcl_Config const cfg[] = {
{"mem_debug", CFG_MEMDEBUG},
{"compile_debug", CFG_COMPILE_DEBUG},
{"compile_stats", CFG_COMPILE_STATS},
+#endif
/* Runtime paths to various stuff */
@@ -113,6 +111,9 @@ static Tcl_Config const cfg[] = {
{"scriptdir,runtime", CFG_RUNTIME_SCRDIR},
{"includedir,runtime", CFG_RUNTIME_INCDIR},
{"docdir,runtime", CFG_RUNTIME_DOCDIR},
+#if !defined(STATIC_BUILD)
+ {"dllfile,runtime", CFG_RUNTIME_DLLFILE},
+#endif
/* Installation paths to various stuff */
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index cb420fd..f2bc0da 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -40,6 +40,14 @@
# define _TCHAR_DEFINED
#endif
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
@@ -59,7 +67,7 @@ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
Tcl_DString *dsPtr);
/* Slot 2 is reserved */
/* 3 */
-EXTERN void TclUnusedStubEntry(void);
+EXTERN void Tcl_WinConvertError(unsigned errCode);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
@@ -73,7 +81,8 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
int hasResourceFile, int maxPathLen,
char *libraryPath);
/* 2 */
-EXTERN void TclUnusedStubEntry(void);
+EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
+ const void *runLoopMode);
#endif /* MACOSX */
typedef struct TclPlatStubs {
@@ -84,12 +93,12 @@ typedef struct TclPlatStubs {
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
void (*reserved2)(void);
- void (*tclUnusedStubEntry) (void); /* 3 */
+ void (*tcl_WinConvertError) (unsigned errCode); /* 3 */
#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 */
- void (*tclUnusedStubEntry) (void); /* 2 */
+ void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */
#endif /* MACOSX */
} TclPlatStubs;
@@ -111,23 +120,22 @@ extern const TclPlatStubs *tclPlatStubsPtr;
#define Tcl_WinTCharToUtf \
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
/* Slot 2 is reserved */
-#define TclUnusedStubEntry \
- (tclPlatStubsPtr->tclUnusedStubEntry) /* 3 */
+#define Tcl_WinConvertError \
+ (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#define TclUnusedStubEntry \
- (tclPlatStubsPtr->tclUnusedStubEntry) /* 2 */
+#define Tcl_MacOSXNotifierAddRunLoopMode \
+ (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
-#undef TclUnusedStubEntry
#ifdef MAC_OSX_TCL /* MACOSX */
#undef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e)
@@ -136,6 +144,16 @@ extern const TclPlatStubs *tclPlatStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#endif /* _TCLPLATDECLS */
-
+#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\
+ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)
+#undef Tcl_WinUtfToTChar
+#undef Tcl_WinTCharToUtf
+#ifdef _WIN32
+#define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
+#define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+#endif
+#endif
+#endif /* _TCLPLATDECLS */
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 9485567..d3f6233 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -24,21 +24,6 @@
#endif
#include "tcl.h"
-#if !defined(LLONG_MIN)
-# ifdef TCL_WIDE_INT_IS_LONG
-# define LLONG_MIN LONG_MIN
-# else
-# ifdef LLONG_BIT
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1)))
-# else
-/* Assume we're on a system with a 64-bit 'long long' type */
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63))
-# endif
-# endif
-/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */
-# define LLONG_MAX (~LLONG_MIN)
-#endif
-
#define UWIDE_MAX ((Tcl_WideUInt)-1)
#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1))
#define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1))
diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index c817faa..ecdf652 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -4,8 +4,8 @@
* This file contains procedures that generate strings corresponding to
* various POSIX-related codes, such as errno and signals.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index cca13e8..b32dd63 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -5,8 +5,8 @@
* sure that widget records and other data structures aren't reallocated
* when there are nested functions that depend on their existence.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,7 +22,7 @@
typedef struct {
ClientData clientData; /* Address of preserved block. */
- int refCount; /* Number of Tcl_Preserve calls in effect for
+ size_t refCount; /* Number of Tcl_Preserve calls in effect for
* block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
@@ -63,7 +63,7 @@ typedef struct HandleStruct {
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
- int refCount; /* Number of TclHandlePreserve() calls in
+ size_t refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
@@ -83,7 +83,6 @@ typedef struct HandleStruct {
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
void
TclFinalizePreserve(void)
{
@@ -144,7 +143,7 @@ Tcl_Preserve(
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
- refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference));
+ refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference));
}
/*
@@ -155,7 +154,7 @@ Tcl_Preserve(
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
- refPtr->freeProc = TCL_STATIC;
+ refPtr->freeProc = 0;
inUse += 1;
Tcl_MutexUnlock(&preserveMutex);
}
@@ -195,7 +194,7 @@ Tcl_Release(
continue;
}
- if (--refPtr->refCount != 0) {
+ if (refPtr->refCount-- > 1) {
Tcl_MutexUnlock(&preserveMutex);
return;
}
@@ -226,7 +225,7 @@ Tcl_Release(
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
- freeProc(clientData);
+ freeProc((char *)clientData);
}
}
return;
@@ -293,7 +292,7 @@ Tcl_EventuallyFree(
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
- freeProc(clientData);
+ freeProc((char *)clientData);
}
}
@@ -327,7 +326,7 @@ TclHandleCreate(
* be tracked for deletion. Must not be
* NULL. */
{
- HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct));
+ HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
@@ -459,7 +458,7 @@ TclHandleRelease(
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
- if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
+ if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
ckfree(handlePtr);
}
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index bf24c83..3ada9ea 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -4,10 +4,10 @@
* This file contains routines that implement Tcl procedures, including
* the "proc" and "uplevel" commands.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004-2006 Miguel Sofer
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2004-2006 Miguel Sofer
+ * Copyright © 2007 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.
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Variables that are part of the [apply] command implementation and which
@@ -33,8 +34,7 @@ typedef struct {
static void DupLambdaInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static void FreeLambdaInternalRep(Tcl_Obj *objPtr);
-static int InitArgsAndLocals(Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int skip);
+static int InitArgsAndLocals(Tcl_Interp *interp, int skip);
static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
Namespace *nsPtr);
@@ -67,8 +67,24 @@ const Tcl_ObjType tclProcBodyType = {
* should panic instead. */
};
+#define ProcSetInternalRep(objPtr, procPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (procPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \
+ } while (0)
+
+#define ProcGetInternalRep(objPtr, procPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
- * The [upvar]/[uplevel] level reference type. Uses the longValue field
+ * The [upvar]/[uplevel] level reference type. Uses the wideValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
@@ -89,13 +105,31 @@ static const Tcl_ObjType levelReferenceType = {
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
-const Tcl_ObjType tclLambdaType = {
+static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny /* setFromAnyProc */
};
+
+#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = (nsObjPtr); \
+ Tcl_IncrRefCount((nsObjPtr)); \
+ Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \
+ } while (0)
+
+#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &lambdaType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -117,9 +151,9 @@ const Tcl_ObjType tclLambdaType = {
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
@@ -163,7 +197,7 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, simpleName, objv[2],
+ if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
objv[3], &procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
Tcl_AddErrorInfo(interp, simpleName);
@@ -245,7 +279,7 @@ Tcl_ProcObjCmd(
cfPtr->len = 0;
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- (char *)procPtr, &isNew);
+ procPtr, &isNew);
if (!isNew) {
/*
* Get the old command frame and release it. See also
@@ -294,7 +328,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (objv[3]->typePtr == &tclProcBodyType) {
+ if (TclHasInternalRep(objv[3], &tclProcBodyType)) {
goto done;
}
@@ -305,7 +339,7 @@ Tcl_ProcObjCmd(
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
- int numBytes;
+ Tcl_Size numBytes;
procArgs +=4;
while (*procArgs != '\0') {
@@ -319,7 +353,7 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
- procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
+ procBody = TclGetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
@@ -362,7 +396,7 @@ Tcl_ProcObjCmd(
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
- Namespace *nsPtr, /* Namespace containing this proc. */
+ TCL_UNUSED(Namespace *) /*nsPtr*/,
const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
@@ -370,13 +404,14 @@ TclCreateProc(
{
Interp *iPtr = (Interp *) interp;
- Proc *procPtr;
- int i, result, numArgs;
+ Proc *procPtr = NULL;
+ Tcl_Size i, numArgs;
CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
- int precompiled = 0;
+ int precompiled = 0, result;
- if (bodyPtr->typePtr == &tclProcBodyType) {
+ ProcGetInternalRep(bodyPtr, procPtr);
+ if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
* compiled, and it is not shared with anyone else, so it's OK not to
@@ -389,7 +424,6 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -411,7 +445,7 @@ TclCreateProc(
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
- int length;
+ Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
@@ -451,7 +485,7 @@ TclCreateProc(
* in the Proc.
*/
- result = TclListObjGetElements(interp, argsPtr, &numArgs, &argArray);
+ result = TclListObjGetElementsM(interp, argsPtr, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -473,15 +507,15 @@ TclCreateProc(
}
for (i = 0; i < numArgs; i++) {
- const char *argname, *p, *last;
- int fieldCount, nameLength;
+ const char *argname, *argnamei, *argnamelast;
+ Tcl_Size fieldCount, nameLength;
Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = TclListObjGetElements(interp, argArray[i], &fieldCount,
+ result = TclListObjGetElementsM(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
@@ -496,7 +530,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
+ if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
@@ -504,15 +538,17 @@ TclCreateProc(
goto procError;
}
+ argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
+
/*
* Check that the formal parameter name is a scalar.
*/
- p = argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
- last = argname + nameLength;
- while (p < last) {
- if (*p == '(') {
- if (last[-1] == ')') { /* We have an array element. */
+ argnamei = argname;
+ argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
+ while (argnamei < argnamelast) {
+ if (*argnamei == '(') {
+ if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
Tcl_GetString(fieldValues[0])));
@@ -520,7 +556,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- } else if (p[0] == ':' && p[1] == ':') {
+ } else if (*argnamei == ':' && *(argnamei+1) == ':') {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
@@ -530,7 +566,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei++;
}
if (precompiled) {
@@ -564,11 +600,9 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- int tmpLength, valueLength;
- const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
- &tmpLength);
- const char *value = TclGetStringFromObj(fieldValues[1],
- &valueLength);
+ Tcl_Size tmpLength, valueLength;
+ const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength);
+ const char *value = TclGetStringFromObj(fieldValues[1], &valueLength);
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0
@@ -599,7 +633,7 @@ TclCreateProc(
*/
localPtr = (CompiledLocal *)ckalloc(
- TclOffset(CompiledLocal, name) + 1U + fieldValues[0]->length);
+ offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -683,56 +717,15 @@ TclGetFrame(
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
- Interp *iPtr = (Interp *) interp;
- int curLevel, level, result;
- CallFrame *framePtr;
-
- /*
- * Parse string to figure out which level number to go to.
- */
-
- result = 1;
- curLevel = iPtr->varFramePtr->level;
- if (*name== '#') {
- if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) {
- goto levelError;
- }
- } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
- if (Tcl_GetInt(NULL, name, &level) != TCL_OK) {
- goto levelError;
- }
- level = curLevel - level;
- } else {
- /*
- * (historical, TODO) If name does not contain a level (#0 or 1),
- * TclGetFrame and Tcl_UpVar2 uses current level - 1
- */
- level = curLevel - 1;
- result = 0;
- name = "1"; /* be more consistent with TclObjGetFrame (error at top - 1) */
- }
-
- /*
- * Figure out which frame to use, and return it to the caller.
- */
-
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
- }
- }
- if (framePtr == NULL) {
- goto levelError;
- }
-
- *framePtrPtr = framePtr;
- return result;
-
- levelError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
- return -1;
+ int result;
+ Tcl_Obj obj;
+
+ obj.bytes = (char *) name;
+ obj.length = strlen(name);
+ obj.typePtr = NULL;
+ result = TclObjGetFrame(interp, &obj, framePtrPtr);
+ TclFreeInternalRep(&obj);
+ return result;
}
/*
@@ -769,7 +762,9 @@ TclObjGetFrame(
{
Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
+ const Tcl_ObjInternalRep *irPtr;
const char *name = NULL;
+ Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
@@ -785,25 +780,34 @@ TclObjGetFrame(
if (objPtr == NULL) {
/* Do nothing */
- } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)
- && (level >= 0)) {
- level = curLevel - level;
- result = 1;
- } else if (objPtr->typePtr == &levelReferenceType) {
- level = (int) objPtr->internalRep.longValue;
+ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) {
+ Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
+ result = -1;
+ } else {
+ level = curLevel - level;
+ result = 1;
+ }
+ } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) {
+ level = irPtr->wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
if (name[0] == '#') {
- if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.longValue = level;
- result = 1;
+ if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
+ if (level < 0 || (level > 0 && name[1] == '-')) {
+ result = -1;
+ } else {
+ Tcl_ObjInternalRep ir;
+
+ ir.wideValue = level;
+ Tcl_StoreInternalRep(objPtr, &levelReferenceType, &ir);
+ result = 1;
+ }
} else {
result = -1;
}
- } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */
+ } else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
/*
* If this were an integer, we'd have succeeded already.
* Docs say we have to treat this as a 'bad level' error.
@@ -812,11 +816,16 @@ TclObjGetFrame(
}
}
- if (result == 0) {
- level = curLevel - 1;
- name = "1";
- }
if (result != -1) {
+ /* if relative current level */
+ if (result == 0) {
+ if (!curLevel) {
+ /* we are in top-level, so simply generate bad level */
+ name = "1";
+ goto badLevel;
+ }
+ level = curLevel - 1;
+ }
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
@@ -827,11 +836,11 @@ TclObjGetFrame(
}
}
}
- if (name == NULL) {
- name = TclGetString(objPtr);
- }
}
-
+badLevel:
+ if (name == NULL) {
+ name = objPtr ? TclGetString(objPtr) : "1" ;
+ }
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
return -1;
@@ -856,7 +865,7 @@ TclObjGetFrame(
static int
Uplevel_Callback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -877,7 +886,7 @@ Uplevel_Callback(
int
Tcl_UplevelObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -887,7 +896,7 @@ Tcl_UplevelObjCmd(
int
TclNRUplevelObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -910,8 +919,9 @@ TclNRUplevelObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
- int status ,llength;
- status = TclListObjLength(interp, objv[1], &llength);
+ int status;
+ Tcl_Size llength;
+ status = TclListObjLengthM(interp, objv[1], &llength);
if (status == TCL_OK && llength > 1) {
/* the first argument can't interpreted as a level. Avoid
* generating a string representation of the script. */
@@ -1131,6 +1141,7 @@ ProcWrongNumArgs(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
void
TclInitCompiledLocals(
Tcl_Interp *interp, /* Current interpreter. */
@@ -1142,10 +1153,10 @@ TclInitCompiledLocals(
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr == NULL) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1157,6 +1168,7 @@ TclInitCompiledLocals(
InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1289,7 +1301,7 @@ TclFreeLocalCache(
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
- int i;
+ Tcl_Size i;
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
@@ -1308,9 +1320,9 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
- int localCt = procPtr->numCompiledLocals;
- int numArgs = procPtr->numArgs, i = 0;
+ ByteCode *codePtr;
+ Tcl_Size localCt = procPtr->numCompiledLocals;
+ Tcl_Size numArgs = procPtr->numArgs, i = 0;
Tcl_Obj **namePtr;
Var *varPtr;
@@ -1318,13 +1330,15 @@ InitLocalCache(
CompiledLocal *localPtr;
int isNew;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
- localCachePtr = (LocalCache *)ckalloc(TclOffset(LocalCache, varName0)
+ localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0)
+ localCt * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
@@ -1379,17 +1393,18 @@ static int
InitArgsAndLocals(
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". */
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Make sure that the local cache of variable names and initial values has
* been initialised properly .
@@ -1470,7 +1485,7 @@ InitArgsAndLocals(
varPtr->flags = 0;
if (defPtr && defPtr->flags & VAR_IS_ARGS) {
- Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+ Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i);
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
@@ -1540,11 +1555,11 @@ InitArgsAndLocals(
int
TclPushProcCallFrame(
- ClientData clientData, /* Record describing procedure to be
+ void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
- int objc, /* Count of number of arguments to this
+ Tcl_Size objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[], /* Argument value objects. */
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
@@ -1564,7 +1579,8 @@ TclPushProcCallFrame(
* local variables are found while compiling.
*/
- if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
Interp *iPtr = (Interp *) interp;
/*
@@ -1577,7 +1593,6 @@ TclPushProcCallFrame(
* Ensure the ByteCode's procPtr is the same (or it's precompiled).
*/
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1635,7 +1650,7 @@ TclPushProcCallFrame(
int
TclObjInterpProc(
- ClientData clientData, /* Record describing procedure to be
+ void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
@@ -1652,7 +1667,7 @@ TclObjInterpProc(
int
TclNRInterpProc(
- ClientData clientData, /* Record describing procedure to be
+ void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
@@ -1668,6 +1683,43 @@ TclNRInterpProc(
}
return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
+
+static int
+NRInterpProc2(
+ void *clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ size_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ int result = TclPushProcCallFrame(clientData, interp, objc, objv,
+ /*isLambda*/ 0);
+
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+}
+
+static int
+ObjInterpProc2(
+ void *clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ size_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ /*
+ * Not used much in the core; external interface for iTcl
+ */
+
+ return Tcl_NRCallObjProc2(interp, NRInterpProc2, clientData, objc, objv);
+}
+
/*
*----------------------------------------------------------------------
@@ -1692,7 +1744,7 @@ TclNRInterpProcCore(
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,
+ Tcl_Size 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
* results of the overall procedure. */
@@ -1703,7 +1755,7 @@ TclNRInterpProcCore(
CallFrame *freePtr;
ByteCode *codePtr;
- result = InitArgsAndLocals(interp, procNameObj, skip);
+ result = InitArgsAndLocals(interp, skip);
if (result != TCL_OK) {
freePtr = iPtr->framePtr;
Tcl_PopCallFrame(interp); /* Pop but do not free. */
@@ -1716,7 +1768,7 @@ TclNRInterpProcCore(
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
CallFrame *framePtr = iPtr->varFramePtr;
- int i;
+ Tcl_Size i;
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
fprintf(stdout, "Calling lambda ");
@@ -1734,9 +1786,9 @@ TclNRInterpProcCore(
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
const char *a[10];
- int i;
+ Tcl_Size i;
for (i = 0 ; i < 10 ; i++) {
a[i] = (l < iPtr->varFramePtr->objc ?
@@ -1755,7 +1807,7 @@ TclNRInterpProcCore(
TclDecrRefCount(info);
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
@@ -1763,7 +1815,7 @@ TclNRInterpProcCore(
(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
@@ -1777,7 +1829,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1786,7 +1838,7 @@ TclNRInterpProcCore(
static int
InterpProcNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1797,7 +1849,7 @@ InterpProcNR2(
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
@@ -1820,7 +1872,7 @@ InterpProcNR2(
done:
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
Tcl_Obj *r = Tcl_GetObjResult(interp);
TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
@@ -1909,7 +1961,9 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1926,7 +1980,7 @@ TclProcCompileProc(
* are not recompiled, even if things have changed.
*/
- if (bodyPtr->typePtr == &tclByteCodeType) {
+ if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
@@ -1947,11 +2001,12 @@ TclProcCompileProc(
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- TclFreeIntRep(bodyPtr);
+ Tcl_StoreInternalRep(bodyPtr, &tclByteCodeType, NULL);
+ codePtr = NULL;
}
}
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ if (codePtr == NULL) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
@@ -1970,6 +2025,9 @@ TclProcCompileProc(
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
+#else
+ (void)description;
+ (void)procName;
#endif
/*
@@ -2072,13 +2130,14 @@ MakeProcError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ int overflow, limit = 60;
+ Tcl_Size nameLen;
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
@@ -2104,7 +2163,7 @@ MakeProcError(
void
TclProcDeleteProc(
- ClientData clientData) /* Procedure to be deleted. */
+ void *clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
@@ -2144,11 +2203,11 @@ TclProcCleanupProc(
if (bodyPtr != NULL) {
/* procPtr is stored in body's ByteCode, so ensure to reset it. */
- if (bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
- if (codePtr->procPtr == procPtr) {
- codePtr->procPtr = NULL;
- }
+ ByteCode *codePtr;
+
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL && codePtr->procPtr == procPtr) {
+ codePtr->procPtr = NULL;
}
Tcl_DecrRefCount(bodyPtr);
}
@@ -2253,15 +2312,16 @@ TclUpdateReturnInfo(
/*
*----------------------------------------------------------------------
*
- * TclGetObjInterpProc --
+ * TclGetObjInterpProc/TclGetObjInterpProc2 --
*
- * Returns a pointer to the TclObjInterpProc function; this is different
- * from the value obtained from the TclObjInterpProc reference on systems
- * like Windows where import and export versions of a function exported
- * by a DLL exist.
+ * Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions;
+ * this is different from the value obtained from the TclObjInterpProc
+ * reference on systems like Windows where import and export versions
+ * of a function exported by a DLL exist.
*
* Results:
- * Returns the internal address of the TclObjInterpProc function.
+ * Returns the internal address of the TclObjInterpProc/ObjInterpProc2
+ * functions.
*
* Side effects:
* None.
@@ -2274,6 +2334,12 @@ TclGetObjInterpProc(void)
{
return TclObjInterpProc;
}
+
+Tcl_ObjCmdProc2 *
+TclGetObjInterpProc2(void)
+{
+ return ObjInterpProc2;
+}
/*
*----------------------------------------------------------------------
@@ -2307,10 +2373,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
-
- procPtr->refCount++;
+ ProcSetInternalRep(objPtr, procPtr);
}
return objPtr;
@@ -2338,11 +2401,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+ ProcGetInternalRep(srcPtr, procPtr);
- dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- procPtr->refCount++;
+ ProcSetInternalRep(dupPtr, procPtr);
}
/*
@@ -2368,7 +2430,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+
+ ProcGetInternalRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2394,15 +2458,15 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
procPtr->refCount++;
- Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &tclLambdaType;
+
+ LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr);
}
static void
@@ -2410,14 +2474,16 @@ FreeLambdaInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
- if (procPtr->refCount-- == 1) {
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
+
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
- objPtr->typePtr = NULL;
}
static int
@@ -2428,7 +2494,8 @@ SetLambdaFromAny(
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
- int isNew, objc, result;
+ int isNew, result;
+ Tcl_Size objc;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
@@ -2438,10 +2505,18 @@ SetLambdaFromAny(
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
- * length is not 2, then it cannot be converted to tclLambdaType.
+ * length is not 2, then it cannot be converted to lambdaType.
*/
- result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ result = TclListObjLengthM(NULL, objPtr, &objc);
+ if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't interpret \"%s\" as a lambda expression",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
+ return TCL_ERROR;
+ }
+ result = TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
@@ -2579,21 +2654,42 @@ SetLambdaFromAny(
}
}
- Tcl_IncrRefCount(nsObjPtr);
-
/*
* Free the list internalrep of objPtr - this will free argsPtr, but
* bodyPtr retains a reference from the Proc structure. Then finish the
- * conversion to tclLambdaType.
+ * conversion to lambdaType.
*/
- TclFreeIntRep(objPtr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
- objPtr->typePtr = &tclLambdaType;
+ LambdaSetInternalRep(objPtr, procPtr, nsObjPtr);
return TCL_OK;
}
+
+Proc *
+TclGetLambdaFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Obj **nsObjPtrPtr)
+{
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+
+ if (procPtr == NULL) {
+ if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ }
+
+ assert(procPtr != NULL);
+ if (procPtr->iPtr != (Interp *)interp) {
+ return NULL;
+ }
+
+ *nsObjPtrPtr = nsObjPtr;
+ return procPtr;
+}
/*
*----------------------------------------------------------------------
@@ -2614,7 +2710,7 @@ SetLambdaFromAny(
int
Tcl_ApplyObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2624,12 +2720,11 @@ Tcl_ApplyObjCmd(
int
TclNRApplyObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
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;
@@ -2647,24 +2742,17 @@ TclNRApplyObjCmd(
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &tclLambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
- }
+ procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr);
- if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
- result = SetLambdaFromAny(interp, lambdaPtr);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
/*
- * Find the namespace where this lambda should run, and push a call frame
- * for that namespace. Note that TclObjInterpProc() will pop it.
+ * Push a call frame for the lambda namespace.
+ * Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
@@ -2701,7 +2789,7 @@ TclNRApplyObjCmd(
static int
ApplyNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2736,13 +2824,14 @@ MakeLambdaError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ int overflow, limit = 60;
+ Tcl_Size nameLen;
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
new file mode 100644
index 0000000..aec8c0a
--- /dev/null
+++ b/generic/tclProcess.c
@@ -0,0 +1,950 @@
+/*
+ * tclProcess.c --
+ *
+ * This file implements the "tcl::process" ensemble for subprocess
+ * management as defined by TIP #462.
+ *
+ * Copyright © 2017 Frederic Bonnet.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+
+/*
+ * Autopurge flag. Process-global because of the way Tcl manages child
+ * processes (see tclPipe.c).
+ */
+
+static int autopurge = 1; /* Autopurge flag. */
+
+/*
+ * Hash tables that keeps track of all child process statuses. Keys are the
+ * child process ids and resolved pids, values are (ProcessInfo *).
+ */
+
+typedef struct ProcessInfo {
+ Tcl_Pid pid; /* Process id. */
+ int resolvedPid; /* Resolved process id. */
+ int purge; /* Purge eventualy. */
+ TclProcessWaitStatus status;/* Process status. */
+ int code; /* Error code, exit status or signal
+ number. */
+ Tcl_Obj *msg; /* Error message. */
+ Tcl_Obj *error; /* Error code. */
+} ProcessInfo;
+static Tcl_HashTable infoTablePerPid;
+static Tcl_HashTable infoTablePerResolvedPid;
+static int infoTablesInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(infoTablesMutex)
+
+ /*
+ * Prototypes for functions defined later in this file:
+ */
+
+static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
+ int resolvedPid);
+static void FreeProcessInfo(ProcessInfo *info);
+static int RefreshProcessInfo(ProcessInfo *info, int options);
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
+ int options, int *codePtr, Tcl_Obj **msgPtr,
+ Tcl_Obj **errorObjPtr);
+static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
+static Tcl_ObjCmdProc ProcessListObjCmd;
+static Tcl_ObjCmdProc ProcessStatusObjCmd;
+static Tcl_ObjCmdProc ProcessPurgeObjCmd;
+static Tcl_ObjCmdProc ProcessAutopurgeObjCmd;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitProcessInfo --
+ *
+ * Initializes the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory written.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+InitProcessInfo(
+ ProcessInfo *info, /* Structure to initialize. */
+ Tcl_Pid pid, /* Process id. */
+ int resolvedPid) /* Resolved process id. */
+{
+ info->pid = pid;
+ info->resolvedPid = resolvedPid;
+ info->purge = 0;
+ info->status = TCL_PROCESS_UNCHANGED;
+ info->code = 0;
+ info->msg = NULL;
+ info->error = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeProcessInfo --
+ *
+ * Free the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory deallocated, Tcl_Obj refcount decreased.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+FreeProcessInfo(
+ ProcessInfo *info) /* Structure to free. */
+{
+ /*
+ * Free stored Tcl_Objs.
+ */
+
+ if (info->msg) {
+ Tcl_DecrRefCount(info->msg);
+ }
+ if (info->error) {
+ Tcl_DecrRefCount(info->error);
+ }
+
+ /*
+ * Free allocated structure.
+ */
+
+ ckfree(info);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RefreshProcessInfo --
+ *
+ * Refresh process info.
+ *
+ * Results:
+ * Nonzero if state changed, else zero.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+RefreshProcessInfo(
+ ProcessInfo *info, /* Structure to refresh. */
+ int options /* Options passed to WaitProcessStatus. */
+)
+{
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Refresh & store status.
+ */
+
+ info->status = WaitProcessStatus(info->pid, info->resolvedPid,
+ options, &info->code, &info->msg, &info->error);
+ if (info->msg) Tcl_IncrRefCount(info->msg);
+ if (info->error) Tcl_IncrRefCount(info->error);
+ return (info->status != TCL_PROCESS_UNCHANGED);
+ } else {
+ /*
+ * No change.
+ */
+
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitProcessStatus --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+WaitProcessStatus(
+ Tcl_Pid pid, /* Process id. */
+ int resolvedPid, /* Resolved process id. */
+ int options, /* Options passed to Tcl_WaitPid. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ int waitStatus;
+ Tcl_Obj *errorStrings[5];
+ const char *msg;
+
+ pid = Tcl_WaitPid(pid, &waitStatus, options);
+ if (pid == 0) {
+ /*
+ * No change.
+ */
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Get process status.
+ */
+
+ if (pid == (Tcl_Pid)-1) {
+ /*
+ * POSIX errName msg
+ */
+
+ msg = Tcl_ErrnoMsg(errno);
+ 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?)";
+ }
+ if (codePtr) *codePtr = errno;
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "error waiting for process to exit: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
+ errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
+ errorStrings[2] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ return TCL_PROCESS_ERROR;
+ } else if (WIFEXITED(waitStatus)) {
+ if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
+ if (!WEXITSTATUS(waitStatus)) {
+ /*
+ * Normal exit.
+ */
+
+ if (msgObjPtr) *msgObjPtr = NULL;
+ if (errorObjPtr) *errorObjPtr = NULL;
+ } else {
+ /*
+ * CHILDSTATUS pid code
+ *
+ * Child exited with a non-zero exit status.
+ */
+
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child process exited abnormally", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ }
+ return TCL_PROCESS_EXITED;
+ } else if (WIFSIGNALED(waitStatus)) {
+ /*
+ * CHILDKILLED pid sigName msg
+ *
+ * Child killed because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
+ if (codePtr) *codePtr = WTERMSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child killed: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_SIGNALED;
+ } else if (WIFSTOPPED(waitStatus)) {
+ /*
+ * CHILDSUSP pid sigName msg
+ *
+ * Child suspended because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
+ if (codePtr) *codePtr = WSTOPSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child suspended: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_STOPPED;
+ } else {
+ /*
+ * TCL OPERATION EXEC ODDWAITRESULT
+ *
+ * Child wait status didn't make sense.
+ */
+
+ if (codePtr) *codePtr = waitStatus;
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child wait status didn't make sense\n", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("TCL", -1);
+ errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
+ errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
+ errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
+ TclNewIntObj(errorStrings[4], resolvedPid);
+ *errorObjPtr = Tcl_NewListObj(5, errorStrings);
+ }
+ return TCL_PROCESS_UNKNOWN_STATUS;
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildProcessStatusObj --
+ *
+ * Build a list object with process status. The first element is always
+ * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
+ * In the latter case, the second element is the error message and the
+ * third element is a Tcl error code (see tclvars).
+ *
+ * Results:
+ * A list object.
+ *
+ * Side effects:
+ * Tcl_Objs are created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+BuildProcessStatusObj(
+ ProcessInfo *info)
+{
+ Tcl_Obj *resultObjs[3];
+
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Process still running, return empty obj.
+ */
+
+ return Tcl_NewObj();
+ }
+ if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
+ /*
+ * Normal exit, return TCL_OK.
+ */
+
+ return Tcl_NewWideIntObj(TCL_OK);
+ }
+
+ /*
+ * Abnormal exit, return {TCL_ERROR msg error}
+ */
+
+ TclNewIntObj(resultObjs[0], TCL_ERROR);
+ resultObjs[1] = info->msg;
+ resultObjs[2] = info->error;
+ return Tcl_NewListObj(3, resultObjs);
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessListObjCmd --
+ *
+ * This function implements the 'tcl::process list' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Access to the internal structures is protected by infoTablesMutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessListObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *list;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the list of all chid process ids.
+ */
+
+ list = Tcl_NewListObj(0, NULL);
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ Tcl_ListObjAppendElement(interp, list,
+ Tcl_NewWideIntObj(info->resolvedPid));
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_SetObjResult(interp, list);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessStatusObjCmd --
+ *
+ * This function implements the 'tcl::process status' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Access to the internal structures is protected by infoTablesMutex.
+ * Calls RefreshProcessInfo, which can block if -wait switch is given.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessStatusObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *dict;
+ int index, options = WNOHANG;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ int pid;
+ Tcl_Obj *const *savedobjv = objv;
+ static const char *const switches[] = {
+ "-wait", "--", NULL
+ };
+ enum switchesEnum {
+ STATUS_WAIT, STATUS_LAST
+ };
+
+ while (objc > 1) {
+ if (TclGetString(objv[1])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ++objv; --objc;
+ if (STATUS_WAIT == (enum switchesEnum) index) {
+ options = 0;
+ } else {
+ break;
+ }
+ }
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 1) {
+ /*
+ * Return a dict with all child process statuses.
+ */
+
+ dict = Tcl_NewDictObj();
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ } else {
+ /*
+ * Only return statuses of provided processes.
+ */
+
+ result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ dict = Tcl_NewDictObj();
+ Tcl_MutexLock(&infoTablesMutex);
+ for (i = 0; i < numPids; i++) {
+ result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
+ if (result != TCL_OK) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_DecrRefCount(dict);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+ Tcl_SetObjResult(interp, dict);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessPurgeObjCmd --
+ *
+ * This function implements the 'tcl::process purge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Frees all ProcessInfo structures with their purge flag set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessPurgeObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ int pid;
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First reap detached procs so that their purge flag is up-to-date.
+ */
+
+ Tcl_ReapDetachedProcs();
+
+ if (objc == 1) {
+ /*
+ * Purge all terminated processes.
+ */
+
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ } else {
+ /*
+ * Purge only provided processes.
+ */
+
+ result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_MutexLock(&infoTablesMutex);
+ for (i = 0; i < numPids; i++) {
+ result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
+ if (result != TCL_OK) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessAutopurgeObjCmd --
+ *
+ * This function implements the 'tcl::process autopurge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Alters detached process handling by Tcl_ReapDetachedProcs().
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessAutopurgeObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ /*
+ * Set given value.
+ */
+
+ int flag;
+ int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ autopurge = !!flag;
+ }
+
+ /*
+ * Return current value.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitProcessCmd --
+ *
+ * This procedure creates the "tcl::process" 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
+TclInitProcessCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+ static const EnsembleImplMap processImplMap[] = {
+ {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
+ {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ Tcl_Command processCmd;
+
+ if (infoTablesInitialized == 0) {
+ Tcl_MutexLock(&infoTablesMutex);
+ if (infoTablesInitialized == 0) {
+ Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
+ infoTablesInitialized = 1;
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
+ Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
+ "process", 0);
+ return processCmd;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessCreated --
+ *
+ * Called when a child process has been created by Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Internal structures are updated with a new ProcessInfo.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclProcessCreated(
+ Tcl_Pid pid) /* Process id. */
+{
+ int resolvedPid;
+ Tcl_HashEntry *entry, *entry2;
+ int isNew;
+ ProcessInfo *info;
+
+ /*
+ * Get resolved pid first.
+ */
+
+ resolvedPid = TclpGetPid(pid);
+
+ Tcl_MutexLock(&infoTablesMutex);
+
+ /*
+ * Create entry in pid table.
+ */
+
+ entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
+ if (!isNew) {
+ /*
+ * Pid was reused, free old info and reuse structure.
+ */
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(resolvedPid));
+ if (entry2) Tcl_DeleteHashEntry(entry2);
+ FreeProcessInfo(info);
+ }
+
+ /*
+ * Allocate and initialize info structure.
+ */
+
+ info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo));
+ InitProcessInfo(info, pid, resolvedPid);
+
+ /*
+ * Add entry to tables.
+ */
+
+ Tcl_SetHashValue(entry, info);
+ entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
+ &isNew);
+ Tcl_SetHashValue(entry, info);
+
+ Tcl_MutexUnlock(&infoTablesMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessWait --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * Completed process info structures are purged immediately (autopurge on)
+ * or eventually (autopurge off).
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+TclProcessWait(
+ Tcl_Pid pid, /* Process id. */
+ int options, /* Options passed to WaitProcessStatus. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ Tcl_HashEntry *entry;
+ ProcessInfo *info;
+ TclProcessWaitStatus result;
+
+ /*
+ * First search for pid in table.
+ */
+
+ Tcl_MutexLock(&infoTablesMutex);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
+ if (!entry) {
+ /*
+ * Unknown process, just call WaitProcessStatus and return.
+ */
+
+ result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
+ msgObjPtr, errorObjPtr);
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ /*
+ * Process has completed but TclProcessWait has already been called,
+ * so report no change.
+ */
+ Tcl_MutexUnlock(&infoTablesMutex);
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ RefreshProcessInfo(info, options);
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * No change, stop there.
+ */
+ Tcl_MutexUnlock(&infoTablesMutex);
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Set return values.
+ */
+
+ result = info->status;
+ if (codePtr) *codePtr = info->code;
+ if (msgObjPtr) *msgObjPtr = info->msg;
+ if (errorObjPtr) *errorObjPtr = info->error;
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+
+ if (autopurge) {
+ /*
+ * Purge now.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(info->resolvedPid));
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Eventually purge. Subsequent calls will return
+ * TCL_PROCESS_UNCHANGED.
+ */
+
+ info->purge = 1;
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+}
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index bd923ba..bb4ffc9 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -4,8 +4,8 @@
* This file contains the public interfaces to the Tcl regular expression
* mechanism.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -13,6 +13,7 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include <assert.h>
/*
*----------------------------------------------------------------------
@@ -25,7 +26,7 @@
* regex.h regexec.c regfree.c
* regfronts.c regguts.h
*
- * Copyright (c) 1998 Henry Spencer. All rights reserved.
+ * Copyright © 1998 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = {
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
+
+#define RegexpSetInternalRep(objPtr, rePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (rePtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (rePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclRegexpType, &ir); \
+ } while (0)
+
+#define RegexpGetInternalRep(objPtr, rePtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclRegexpType); \
+ (rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -245,7 +263,7 @@ Tcl_RegExpRange(
if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = *endPtr = NULL;
- } else if (regexpPtr->matches[index].rm_so == -1) {
+ } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
@@ -253,8 +271,8 @@ Tcl_RegExpRange(
} else {
string = regexpPtr->string;
}
- *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
- *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
+ *startPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_so);
+ *endPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_eo);
}
}
@@ -346,7 +364,7 @@ TclRegExpRangeUniChar(
* passed to Tcl_RegExpExec. */
int index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
- * subrange, -1 means the range of the
+ * subrange, TCL_INDEX_NONE means the range of the
* rm_extend field. */
int *startPtr, /* Store address of first character in
* (sub-)range here. */
@@ -355,12 +373,12 @@ TclRegExpRangeUniChar(
{
TclRegexp *regexpPtr = (TclRegexp *) re;
- if ((regexpPtr->flags&REG_EXPECT) && (index == -1)) {
+ if ((regexpPtr->flags&REG_EXPECT) && (index == TCL_INDEX_NONE)) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
} else if ((size_t) index > regexpPtr->re.re_nsub) {
- *startPtr = -1;
- *endPtr = -1;
+ *startPtr = TCL_INDEX_NONE;
+ *endPtr = TCL_INDEX_NONE;
} else {
*startPtr = regexpPtr->matches[index].rm_so;
*endPtr = regexpPtr->matches[index].rm_eo;
@@ -464,7 +482,7 @@ Tcl_RegExpExecObj(
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
- udata = Tcl_GetUnicodeFromObj(textObj, &length);
+ udata = TclGetUnicodeFromObj_(textObj, &length);
if (offset > length) {
offset = length;
@@ -580,14 +598,9 @@ Tcl_GetRegExpFromObj(
TclRegexp *regexpPtr;
const char *pattern;
- /*
- * This is OK because we only actually interpret this value properly as a
- * TclRegexp* when the type is tclRegexpType.
- */
-
- regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ RegexpGetInternalRep(objPtr, regexpPtr);
- if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
+ if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
@@ -595,21 +608,7 @@ Tcl_GetRegExpFromObj(
return NULL;
}
- /*
- * Add a reference to the regexp so it will persist even if it is
- * pushed out of the current thread's regexp cache. This reference
- * will be removed when the object's internal rep is freed.
- */
-
- regexpPtr->refCount++;
-
- /*
- * Free the old representation and set our type.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
- objPtr->typePtr = &tclRegexpType;
+ RegexpSetInternalRep(objPtr, regexpPtr);
}
return (Tcl_RegExp) regexpPtr;
}
@@ -678,8 +677,8 @@ TclRegAbout(
*/
TclNewObj(resultObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewIntObj((int) regexpPtr->re.re_nsub));
+ TclNewIndexObj(infoObj, regexpPtr->re.re_nsub);
+ Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
/*
* Now append a list of all the bit-flags set for the RE.
@@ -756,7 +755,11 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpRepPtr;
+
+ RegexpGetInternalRep(objPtr, regexpRepPtr);
+
+ assert(regexpRepPtr != NULL);
/*
* If this is the last reference to the regexp, free it.
@@ -765,7 +768,6 @@ FreeRegexpInternalRep(
if (regexpRepPtr->refCount-- <= 1) {
FreeRegexp(regexpRepPtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -790,11 +792,13 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpPtr;
+
+ RegexpGetInternalRep(srcPtr, regexpPtr);
+
+ assert(regexpPtr != NULL);
- regexpPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->typePtr = &tclRegexpType;
+ RegexpSetInternalRep(copyPtr, regexpPtr);
}
/*
@@ -955,7 +959,7 @@ CompileRegexp(
if (TclReToGlob(NULL, string, length, &stringBuf, &exact,
NULL) == TCL_OK) {
- regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
+ regexpPtr->globObjPtr = Tcl_DStringToObj(&stringBuf);
Tcl_IncrRefCount(regexpPtr->globObjPtr);
} else {
regexpPtr->globObjPtr = NULL;
@@ -1049,7 +1053,7 @@ FreeRegexp(
static void
FinalizeRegexp(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
int i;
TclRegexp *regexpPtr;
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 3b2433e..a263dfd 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -37,7 +37,7 @@ typedef struct TclRegexp {
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
- int refCount; /* Count of number of references to this
+ size_t refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index 974737e..ff88ffd 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -6,7 +6,7 @@
* name resolution rules to the Tcl language. Rules can be applied to a
* particular namespace, to the interpreter as a whole, or both.
*
- * Copyright (c) 1998 Lucent Technologies, Inc.
+ * Copyright © 1998 Lucent Technologies, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -101,9 +101,9 @@ Tcl_AddInterpResolvers(
* list, so that it overrides existing schemes.
*/
- resPtr = ckalloc(sizeof(ResolverScheme));
+ resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme));
len = strlen(name) + 1;
- resPtr->name = ckalloc(len);
+ resPtr->name = (char *)ckalloc(len);
memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
@@ -265,7 +265,7 @@ BumpCmdRefEpochs(
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
- Namespace *childNsPtr = Tcl_GetHashValue(entry);
+ Namespace *childNsPtr = (Namespace *)Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index f82e6a4..7e108e9 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -3,7 +3,7 @@
*
* This file contains code to manage the interpreter result.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -27,7 +27,9 @@ enum returnKeys {
static Tcl_Obj ** GetKeys(void);
static void ReleaseKeys(ClientData clientData);
static void ResetObjResult(Interp *iPtr);
+#ifndef TCL_NO_DEPRECATED
static void SetupAppendBuffer(Interp *iPtr, int newSpace);
+#endif /* !TCL_NO_DEPRECATED */
/*
* This structure is used to take a snapshot of the interpreter state in
@@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace);
* then back up to the result or the error that was previously in progress.
*/
-typedef struct InterpState {
+typedef struct {
int status; /* return code status */
int flags; /* Each remaining field saves the */
int returnLevel; /* corresponding field of the Interp */
@@ -75,7 +77,7 @@ Tcl_SaveInterpState(
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
- InterpState *statePtr = ckalloc(sizeof(InterpState));
+ InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
@@ -230,6 +232,7 @@ Tcl_DiscardInterpState(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SaveResult
void
Tcl_SaveResult(
@@ -429,7 +432,7 @@ Tcl_SetResult(
int length = strlen(result);
if (length > TCL_RESULT_SIZE) {
- iPtr->result = ckalloc(length + 1);
+ iPtr->result = (char *)ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
@@ -461,6 +464,7 @@ Tcl_SetResult(
ResetObjResult(iPtr);
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -479,22 +483,26 @@ Tcl_SetResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetStringResult
const char *
Tcl_GetStringResult(
Tcl_Interp *interp)/* Interpreter whose result to return. */
{
+#ifndef TCL_NO_DEPRECATED
+ Interp *iPtr = (Interp *) interp;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
- Interp *iPtr = (Interp *) interp;
-
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return iPtr->result;
+#else
+ return TclGetString(Tcl_GetObjResult(interp));
+#endif
}
/*
@@ -536,6 +544,7 @@ Tcl_SetObjResult(
TclDecrRefCount(oldObjResult);
+#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
@@ -550,6 +559,7 @@ Tcl_SetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif
}
/*
@@ -578,6 +588,7 @@ Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
Interp *iPtr = (Interp *) interp;
+#ifndef TCL_NO_DEPRECATED
Tcl_Obj *objResultPtr;
int length;
@@ -604,6 +615,7 @@ Tcl_GetObjResult(
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
+#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
@@ -640,23 +652,6 @@ Tcl_AppendResultVA(
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
-
- /*
- * Strictly we should call Tcl_GetStringResult(interp) here to make sure
- * that interp->result is correct according to the old contract, but that
- * makes the performance of much code (e.g. in Tk) absolutely awful. So we
- * leave it out; code that really wants interp->result can just insert the
- * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
- */
-
-#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_INTERP_RESULT */
}
/*
@@ -722,6 +717,21 @@ Tcl_AppendElement(
* to result. */
{
Interp *iPtr = (Interp *) interp;
+#ifdef TCL_NO_DEPRECATED
+ Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
+ Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
+ const char *bytes;
+
+ if (Tcl_IsShared(iPtr->objResultPtr)) {
+ Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
+ }
+ bytes = TclGetString(iPtr->objResultPtr);
+ if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) {
+ Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
+ }
+ Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
+ Tcl_DecrRefCount(listPtr);
+#else
char *dst;
int size;
int flags;
@@ -774,6 +784,7 @@ Tcl_AppendElement(
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -795,6 +806,7 @@ Tcl_AppendElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
@@ -834,19 +846,19 @@ SetupAppendBuffer(
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
- char *new;
+ char *newSpacePtr;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
- new = ckalloc(totalSpace);
- strcpy(new, iPtr->result);
+ newSpacePtr = (char *)ckalloc(totalSpace);
+ strcpy(newSpacePtr, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
- iPtr->appendResult = new;
+ iPtr->appendResult = newSpacePtr;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
@@ -895,7 +907,8 @@ Tcl_FreeResult(
ResetObjResult(iPtr);
}
-
+#endif /* !TCL_NO_DEPRECATED */
+
/*
*----------------------------------------------------------------------
*
@@ -922,6 +935,7 @@ Tcl_ResetResult(
Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
+#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -932,6 +946,7 @@ Tcl_ResetResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
@@ -991,14 +1006,14 @@ ResetObjResult(
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if (objResultPtr->bytes != tclEmptyStringRep) {
+ if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
ckfree(objResultPtr->bytes);
}
- objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
- TclFreeIntRep(objResultPtr);
+ TclFreeInternalRep(objResultPtr);
}
}
@@ -1174,8 +1189,8 @@ static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
- Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
- (int) (KEY_LAST * sizeof(Tcl_Obj *)));
+ Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey,
+ KEY_LAST * sizeof(Tcl_Obj *));
if (keys[0] == NULL) {
/*
@@ -1226,7 +1241,7 @@ static void
ReleaseKeys(
ClientData clientData)
{
- Tcl_Obj **keys = clientData;
+ Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
@@ -1286,10 +1301,8 @@ TclProcessReturn(
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
- int infoLen;
-
- (void) TclGetStringFromObj(valuePtr, &infoLen);
- if (infoLen) {
+ (void) TclGetString(valuePtr);
+ if (valuePtr->length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
@@ -1315,12 +1328,12 @@ TclProcessReturn(
* if someone does [return -errorstack [info errorstack]]
*/
- if (TclListObjGetElements(interp, valuePtr, &valueObjc,
+ if (TclListObjGetElementsM(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
@@ -1393,13 +1406,11 @@ TclMergeReturnOptions(
TclNewObj(returnOpts);
for (; objc > 1; objv += 2, objc -= 2) {
- int optLen;
- const char *opt = TclGetStringFromObj(objv[0], &optLen);
- int compareLen;
- const char *compare =
- TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
+ const char *opt = TclGetString(objv[0]);
+ const char *compare = TclGetString(keys[KEY_OPTIONS]);
- if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) {
+ if ((objv[0]->length == keys[KEY_OPTIONS]->length)
+ && (memcmp(opt, compare, objv[0]->length) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
@@ -1479,7 +1490,7 @@ TclMergeReturnOptions(
if (valuePtr != NULL) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorcode.
*/
@@ -1501,7 +1512,7 @@ TclMergeReturnOptions(
if (valuePtr != NULL) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorstack.
*/
@@ -1592,14 +1603,14 @@ Tcl_GetReturnOptions(
if (result == TCL_RETURN) {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewIntObj(iPtr->returnCode));
+ Tcl_NewWideIntObj(iPtr->returnCode));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewIntObj(iPtr->returnLevel));
+ Tcl_NewWideIntObj(iPtr->returnLevel));
} else {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewIntObj(result));
+ Tcl_NewWideIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewIntObj(0));
+ Tcl_NewWideIntObj(0));
}
if (result == TCL_ERROR) {
@@ -1612,7 +1623,7 @@ Tcl_GetReturnOptions(
if (iPtr->errorInfo) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
- Tcl_NewIntObj(iPtr->errorLine));
+ Tcl_NewWideIntObj(iPtr->errorLine));
}
return options;
}
@@ -1671,7 +1682,7 @@ Tcl_SetReturnOptions(
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
- if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
+ if (TCL_ERROR == TclListObjGetElementsM(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected dict but got \"%s\"", TclGetString(options)));
diff --git a/generic/tclScan.c b/generic/tclScan.c
index f37f596..c200fa0 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -3,13 +3,14 @@
*
* This file contains the implementation of the "scan" command.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* 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 "tclTomMath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
@@ -266,7 +267,7 @@ ValidateFormat(
* these are messy operations because we do
* not want to use the formatting engine;
* we're inside there! */
- char buf[TCL_UTF_MAX+1] = "";
+ char buf[5] = "";
/*
* Initialize an array that records the number of times a variable is
@@ -417,14 +418,7 @@ ValidateFormat(
case 'x':
case 'X':
case 'b':
- break;
case 'u':
- if (flags & SCAN_BIG) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unsigned bignum scans are invalid", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
- goto error;
- }
break;
/*
* Bracket terms need special checking
@@ -570,7 +564,7 @@ ValidateFormat(
int
Tcl_ScanObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -586,7 +580,6 @@ Tcl_ScanObjCmd(
Tcl_UniChar ch = 0, sch = 0;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
- (void)dummy;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -903,7 +896,7 @@ Tcl_ScanObjCmd(
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
- &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
+ &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
@@ -931,12 +924,42 @@ Tcl_ScanObjCmd(
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
mp_int big;
- TclBNInitBignumFromWideUInt(&big, (Tcl_WideUInt)wideValue);
- Tcl_SetBignumObj(objPtr, &big);
+ if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create bignum", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ return TCL_ERROR;
+ } else {
+ Tcl_SetBignumObj(objPtr, &big);
+ }
} else {
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
+ }
+ } else if (flags & SCAN_BIG) {
+ if (flags & SCAN_UNSIGNED) {
+ mp_int big;
+ int res = Tcl_GetBignumFromObj(interp, objPtr, &big);
+
+ if (res == TCL_OK) {
+ if (mp_isneg(&big)) {
+ res = TCL_ERROR;
+ }
+ mp_clear(&big);
+ }
+
+ if (res == TCL_ERROR) {
+ if (objs != NULL) {
+ ckfree(objs);
+ }
+ Tcl_DecrRefCount(objPtr);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT",
+ "BADUNSIGNED",NULL);
+ return TCL_ERROR;
+ }
}
- } else if (!(flags & SCAN_BIG)) {
+ } else {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
@@ -947,13 +970,19 @@ Tcl_ScanObjCmd(
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
mp_int big;
- TclBNInitBignumFromWideUInt(&big, (unsigned long)value);
- Tcl_SetBignumObj(objPtr, &big);
+ if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create bignum", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ return TCL_ERROR;
+ } else {
+ Tcl_SetBignumObj(objPtr, &big);
+ }
#else
Tcl_SetWideIntObj(objPtr, (unsigned long)value);
#endif
} else {
- TclSetLongObj(objPtr, value);
+ TclSetIntObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
@@ -964,13 +993,13 @@ Tcl_ScanObjCmd(
* Scan a floating point number
*/
- objPtr = Tcl_NewDoubleObj(0.0);
+ TclNewDoubleObj(objPtr, 0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
- &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
+ &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
@@ -989,8 +1018,10 @@ Tcl_ScanObjCmd(
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objPtr->typePtr == &tclDoubleType) {
- dvalue = objPtr->internalRep.doubleValue;
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(objPtr, &tclDoubleType);
+ if (irPtr) {
+ dvalue = irPtr->doubleValue;
} else
#endif
{
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index c55554c..206407e 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -7,14 +7,14 @@
* into strings of digits, and procedures for interconversion among
* 'double' and 'mp_int' types.
*
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 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.
*/
#include "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <float.h>
#include <math.h>
@@ -22,12 +22,10 @@
#define copysign _copysign
#endif
-/*
- * Define KILL_OCTAL to suppress interpretation of numbers with leading zero
- * as octal. (Ceterum censeo: numeros octonarios delendos esse.)
- */
+#ifndef PRIx64
+# define PRIx64 TCL_LL_MODIFIER "x"
+#endif
-#undef KILL_OCTAL
/*
* This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754
@@ -310,7 +308,7 @@ 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 mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR;
static int NormalizeRightward(Tcl_WideUInt *);
static int RequiredPrecision(Tcl_WideUInt);
static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *,
@@ -332,36 +330,36 @@ static char * StrictQuickFormat(double, int, int, double,
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 char * ShorteningInt64Conversion(Double *, Tcl_WideUInt,
int, int, int, int, int, int, int, int, int,
int, int, int *, char **);
-static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt,
+static char * StrictInt64Conversion(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 *);
+ int, int, mp_int *);
static char * ShorteningBignumConversionPowD(Double *dPtr,
- int convType, Tcl_WideUInt bw, int b2, int b5,
+ 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,
+static char * StrictBignumConversionPowD(
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,
+ mp_int *, int);
+static char * ShorteningBignumConversion(Double *dPtr,
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,
+static char * StrictBignumConversion(
Tcl_WideUInt bw, int b2,
int s2, int s5, int k, int len,
int ilim, int ilim1, int *decpt,
@@ -494,7 +492,7 @@ TclParseNumber(
{
enum State {
INITIAL, SIGNUM, ZERO, ZERO_X,
- ZERO_O, ZERO_B, BINARY,
+ ZERO_O, ZERO_B, ZERO_D, BINARY,
HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
LEADING_RADIX_POINT, FRACTION,
EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
@@ -541,6 +539,9 @@ TclParseNumber(
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
+ mp_err err = MP_OKAY;
+ int under = 0; /* Flag trailing '_' as error if true once
+ * number is accepted. */
#define MOST_BITS (UWIDE_MAX >> 1)
@@ -550,6 +551,20 @@ TclParseNumber(
*/
if (bytes == NULL) {
+ if (interp == NULL && endPtrPtr == NULL) {
+ if (TclHasInternalRep(objPtr, &tclDictType)) {
+ /* A dict can never be a (single) number */
+ return TCL_ERROR;
+ }
+ if (TclHasInternalRep(objPtr, &tclListType)) {
+ int length;
+ /* A list can only be a (single) number if its length == 1 */
+ TclListObjLengthM(NULL, objPtr, &length);
+ if (length != 1) {
+ return TCL_ERROR;
+ }
+ }
+ }
bytes = TclGetString(objPtr);
}
@@ -634,7 +649,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
- if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY)) {
+ if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) {
goto endgame;
}
state = ZERO_X;
@@ -647,7 +662,7 @@ TclParseNumber(
goto zeroo;
}
if (c == 'b' || c == 'B') {
- if (flags & TCL_PARSE_OCTAL_ONLY) {
+ if ((flags & TCL_PARSE_OCTAL_ONLY) || under) {
goto endgame;
}
state = ZERO_B;
@@ -657,11 +672,21 @@ TclParseNumber(
goto zerob;
}
if (c == 'o' || c == 'O') {
+ if (under) {
+ goto endgame;
+ }
explicitOctal = 1;
state = ZERO_O;
break;
}
-#ifdef KILL_OCTAL
+ if (c == 'd' || c == 'D') {
+ if (under) {
+ goto endgame;
+ }
+ state = ZERO_D;
+ break;
+ }
+#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
@@ -681,9 +706,11 @@ TclParseNumber(
zeroo:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
+ under = 0;
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
@@ -704,7 +731,7 @@ TclParseNumber(
|| (octalSignificandWide >
(UWIDE_MAX >> shift)))) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
}
@@ -721,10 +748,17 @@ TclParseNumber(
}
octalSignificandWide += c - '0';
} else {
- mp_mul_2d(&octalSignificandBig, shift,
- &octalSignificandBig);
- mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
- &octalSignificandBig);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&octalSignificandBig, shift,
+ &octalSignificandBig);
+ }
+ if (err == MP_OKAY) {
+ err = mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
+ &octalSignificandBig);
+ }
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
}
}
if (numSigDigs != 0) {
@@ -735,6 +769,10 @@ TclParseNumber(
numTrailZeros = 0;
state = OCTAL;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
/* FALLTHROUGH */
@@ -753,7 +791,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -763,6 +801,7 @@ TclParseNumber(
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -778,12 +817,15 @@ TclParseNumber(
numSigDigs = 1;
}
numTrailZeros = 0;
+ under = 0;
state = BAD_OCTAL;
break;
} else if (c == '.') {
+ under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
+ under = 0;
state = EXPONENT_START;
break;
}
@@ -806,14 +848,22 @@ TclParseNumber(
zerox:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
+ under = 0;
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
+ under = 0;
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
+ under = 0;
d = (c-'a'+10);
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else {
goto endgame;
}
@@ -830,7 +880,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (UWIDE_MAX >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
@@ -846,11 +896,16 @@ TclParseNumber(
significandWide <<= shift;
}
significandWide += d;
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
- mp_add_d(&significandBig, (mp_digit) d, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
+ if (err == MP_OKAY) {
+ err = mp_add_d(&significandBig, (mp_digit) d, &significandBig);
+ }
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
numTrailZeros = 0;
state = HEXADECIMAL;
break;
@@ -864,10 +919,17 @@ TclParseNumber(
zerob:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = BINARY;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else if (c != '1') {
goto endgame;
+ } else {
+ under = 0;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
@@ -882,7 +944,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (UWIDE_MAX >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
@@ -898,22 +960,44 @@ TclParseNumber(
significandWide <<= shift;
}
significandWide += 1;
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
- mp_add_d(&significandBig, (mp_digit) 1, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
+ if (err == MP_OKAY) {
+ err = mp_add_d(&significandBig, (mp_digit) 1, &significandBig);
+ }
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
numTrailZeros = 0;
state = BINARY;
break;
+ case ZERO_D:
+ if (c == '0') {
+ under = 0;
+ numTrailZeros++;
+ } else if ( ! isdigit(UCHAR(c))) {
+ if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
+ }
+ goto endgame;
+ }
+ under = 0;
+ state = DECIMAL;
+ flags |= TCL_PARSE_INTEGER_ONLY;
+ /* FALLTHROUGH */
+
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
@@ -921,6 +1005,7 @@ TclParseNumber(
acceptLen = len;
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -932,14 +1017,21 @@ TclParseNumber(
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
+ under = 0;
state = DECIMAL;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
+ under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
+ under = 0;
state = EXPONENT_START;
break;
}
@@ -965,6 +1057,7 @@ TclParseNumber(
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
+ under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
@@ -981,8 +1074,13 @@ TclParseNumber(
numSigDigs = 1;
}
numTrailZeros = 0;
+ under = 0;
state = FRACTION;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -994,10 +1092,12 @@ TclParseNumber(
*/
if (c == '+') {
+ under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
+ under = 0;
state = EXPONENT_SIGNUM;
break;
}
@@ -1011,8 +1111,13 @@ TclParseNumber(
if (isdigit(UCHAR(c))) {
exponent = c - '0';
+ under = 0;
state = EXPONENT;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -1031,8 +1136,13 @@ TclParseNumber(
} else {
exponent = LONG_MAX;
}
+ under = 0;
state = EXPONENT;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -1043,12 +1153,14 @@ TclParseNumber(
case sI:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
+ under = 0;
state = sINF;
break;
}
@@ -1057,6 +1169,7 @@ TclParseNumber(
acceptState = state;
acceptPoint = p;
acceptLen = len;
+ under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
@@ -1064,24 +1177,28 @@ TclParseNumber(
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
+ under = 0;
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
+ under = 0;
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
+ under = 0;
state = sINFINITY;
break;
}
@@ -1093,12 +1210,14 @@ TclParseNumber(
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
+ under = 0;
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sNAN;
break;
}
@@ -1108,6 +1227,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == '(') {
+ under = 0;
state = sNANPAREN;
break;
}
@@ -1118,12 +1238,14 @@ TclParseNumber(
*/
case sNANHEX:
if (c == ')') {
+ under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
+ under = 0;
break;
}
if (numSigDigs < 13) {
@@ -1138,6 +1260,7 @@ TclParseNumber(
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
+ under = 0;
state = sNANHEX;
break;
}
@@ -1168,10 +1291,13 @@ TclParseNumber(
} else {
/*
* Back up to the last accepting state in the lexer.
+ * If the last char seen is the numeric whitespace character '_',
+ * backup to that.
*/
- p = acceptPoint;
- len = acceptLen;
+ p = under ? acceptPoint-1 : acceptPoint;
+ len = under ? acceptLen-1 : acceptLen;
+
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
@@ -1196,13 +1322,14 @@ TclParseNumber(
*/
if (status == TCL_OK && objPtr != NULL) {
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
switch (acceptState) {
case SIGNUM:
case BAD_OCTAL:
case ZERO_X:
case ZERO_O:
case ZERO_B:
+ case ZERO_D:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
@@ -1226,7 +1353,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
@@ -1239,10 +1366,13 @@ TclParseNumber(
if (significandWide != 0) {
significandWide <<= shift;
}
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto returnInteger;
case HEXADECIMAL:
@@ -1255,7 +1385,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
@@ -1268,10 +1398,13 @@ TclParseNumber(
if (significandWide != 0) {
significandWide <<= shift;
}
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto returnInteger;
case OCTAL:
@@ -1284,7 +1417,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
octalSignificandWide > (MOST_BITS + signum) >> shift)) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
if (shift) {
@@ -1298,94 +1431,72 @@ TclParseNumber(
if (octalSignificandWide != 0) {
octalSignificandWide <<= shift;
}
- } else {
- mp_mul_2d(&octalSignificandBig, shift,
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&octalSignificandBig, shift,
&octalSignificandBig);
}
}
if (!octalSignificandOverflow) {
- if (octalSignificandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (octalSignificandWide <= (MOST_BITS + signum)) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) (-octalSignificandWide);
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) octalSignificandWide;
- }
- break;
- }
-#endif
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- (long) (-octalSignificandWide);
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)(-octalSignificandWide);
} else {
- objPtr->internalRep.longValue =
- (long) octalSignificandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)octalSignificandWide;
}
}
}
- if (octalSignificandOverflow) {
+ if ((err == MP_OKAY) && octalSignificandOverflow) {
if (signum) {
- (void)mp_neg(&octalSignificandBig, &octalSignificandBig);
+ err = mp_neg(&octalSignificandBig, &octalSignificandBig);
}
TclSetBignumInternalRep(objPtr, &octalSignificandBig);
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
break;
case ZERO:
case DECIMAL:
significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
&significandWide, &significandBig, significandOverflow);
- if (!significandOverflow && (significandWide > MOST_BITS+signum)) {
+ if ((err == MP_OKAY) && !significandOverflow && (significandWide > MOST_BITS+signum)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
returnInteger:
if (!significandOverflow) {
- if (significandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (significandWide <= MOST_BITS+signum) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) (-significandWide);
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) significandWide;
- }
- break;
- }
-#endif
- TclBNInitBignumFromWideUInt(&significandBig,
+ if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
+ err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- (long) (-significandWide);
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)(-significandWide);
} else {
- objPtr->internalRep.longValue =
- (long) significandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)significandWide;
}
}
}
- if (significandOverflow) {
+ if ((err == MP_OKAY) && significandOverflow) {
if (signum) {
- (void)mp_neg(&significandBig, &significandBig);
+ err = mp_neg(&significandBig, &significandBig);
}
TclSetBignumInternalRep(objPtr, &significandBig);
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
break;
case FRACTION:
@@ -1550,7 +1661,9 @@ AccumulateDecimalDigit(
* bignum and fall through into the bignum case.
*/
- TclBNInitBignumFromWideUInt(bignumRepPtr, w);
+ if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
+ return 0;
+ }
} else {
/*
* Wide multiplication.
@@ -1570,10 +1683,12 @@ AccumulateDecimalDigit(
* Up to about 8 zeros - single digit multiplication.
*/
- mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
- bignumRepPtr);
- mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr);
+ if ((mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
+ bignumRepPtr) != MP_OKAY)
+ || (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY))
+ return 0;
} else {
+ mp_err err;
/*
* More than single digit multiplication. Multiply by the appropriate
* small powers of 5, and then shift. Large strings of zeroes are
@@ -1584,18 +1699,21 @@ AccumulateDecimalDigit(
*/
n = numZeros + 1;
- mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
- for (i=3; i<=7; ++i) {
+ err = mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
+ for (i = 3; (err == MP_OKAY) && (i <= 7); ++i) {
if (n & (1 << i)) {
- mp_mul(bignumRepPtr, pow5+i, bignumRepPtr);
+ err = mp_mul(bignumRepPtr, pow5+i, bignumRepPtr);
}
}
- while (n >= 256) {
- mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
+ while ((err == MP_OKAY) && (n >= 256)) {
+ err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
n -= 256;
}
- mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr);
- mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr);
+ if ((err != MP_OKAY)
+ || (mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr) != MP_OKAY)
+ || (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
+ return 0;
+ }
}
return 1;
@@ -1704,7 +1822,9 @@ MakeLowPrecisionDouble(
* call MakeHighPrecisionDouble to do it the hard way.
*/
- TclBNInitBignumFromWideUInt(&significandBig, significand);
+ if (mp_init_u64(&significandBig, significand) != MP_OKAY) {
+ return 0.0;
+ }
retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
exponent);
mp_clear(&significandBig);
@@ -1754,7 +1874,7 @@ MakeHighPrecisionDouble(
{
TCL_IEEE_DOUBLE_ROUNDING_DECL
- int machexp; /* Machine exponent of a power of 10. */
+ int machexp = 0; /* Machine exponent of a power of 10. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
@@ -1930,6 +2050,7 @@ RefineApproximation(
Tcl_WideInt rteSigWide; /* Wide integer version of the significand
* for testing evenness */
int i;
+ mp_err err = MP_OKAY;
/*
* The first approximation is always low. If we find that it's HUGE_VAL,
@@ -1978,7 +2099,9 @@ RefineApproximation(
msb = binExponent + M2; /* 1008 */
nDigits = msb / MP_DIGIT_BIT + 1;
- mp_init_size(&twoMv, nDigits);
+ if (mp_init_size(&twoMv, nDigits) != MP_OKAY) {
+ return approxResult;
+ }
i = (msb % MP_DIGIT_BIT + 1);
twoMv.used = nDigits;
significand *= SafeLdExp(1.0, i);
@@ -1988,8 +2111,9 @@ RefineApproximation(
significand = SafeLdExp(significand, MP_DIGIT_BIT);
}
for (i = 0; i <= 8; ++i) {
- if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ if (M5 & (1 << i) && (mp_mul(&twoMv, pow5+i, &twoMv) != MP_OKAY)) {
+ mp_clear(&twoMv);
+ return approxResult;
}
}
@@ -1999,20 +2123,27 @@ RefineApproximation(
* by 2**(M5+exponent+1), which is, of couse, a left shift.
*/
- mp_init_copy(&twoMd, exactSignificand);
- for (i=0; i<=8; ++i) {
+ if (mp_init_copy(&twoMd, exactSignificand) != MP_OKAY) {
+ mp_clear(&twoMv);
+ return approxResult;
+ }
+ for (i = 0; (i <= 8); ++i) {
if ((M5 + exponent) & (1 << i)) {
- mp_mul(&twoMd, pow5+i, &twoMd);
+ err = mp_mul(&twoMd, pow5+i, &twoMd);
}
}
- mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
+ }
/*
* Now let twoMd = twoMd - twoMv, the difference between the exact and
* approximate values.
*/
- mp_sub(&twoMd, &twoMv, &twoMd);
+ if (err == MP_OKAY) {
+ err = mp_sub(&twoMd, &twoMv, &twoMd);
+ }
/*
* The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
@@ -2022,17 +2153,26 @@ RefineApproximation(
*/
scale = binExponent - mantBits - 1;
- mp_set(&twoMv, 1);
- for (i=0; i<=8; ++i) {
+ mp_set_u64(&twoMv, 1);
+ for (i = 0; (i <= 8) && (err == MP_OKAY); ++i) {
if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ err = mp_mul(&twoMv, pow5+i, &twoMv);
}
}
multiplier = M2 + scale + 1;
- if (multiplier > 0) {
- mp_mul_2d(&twoMv, multiplier, &twoMv);
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
+ } else if (multiplier > 0) {
+ err = mp_mul_2d(&twoMv, multiplier, &twoMv);
} else if (multiplier < 0) {
- mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
+ err = mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
+ }
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
}
/*
@@ -2067,7 +2207,7 @@ RefineApproximation(
*/
if (roundToEven) {
rteSignificand = frexp(approxResult, &rteExponent);
- rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION);
+ rteSigWide = (Tcl_WideInt)ldexp(rteSignificand, FP_PRECISION);
if ((rteSigWide & 1) == 0) {
mp_clear(&twoMd);
mp_clear(&twoMv);
@@ -2081,8 +2221,15 @@ RefineApproximation(
*/
shift = mp_count_bits(&twoMv) - FP_PRECISION - 1;
if (shift > 0) {
- mp_div_2d(&twoMv, shift, &twoMv, NULL);
- mp_div_2d(&twoMd, shift, &twoMd, NULL);
+ err = mp_div_2d(&twoMv, shift, &twoMv, NULL);
+ if (err == MP_OKAY) {
+ err = mp_div_2d(&twoMd, shift, &twoMd, NULL);
+ }
+ }
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
}
/*
@@ -2121,7 +2268,7 @@ RefineApproximation(
*----------------------------------------------------------------------
*/
-static inline void
+static inline mp_err
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
@@ -2130,23 +2277,25 @@ MulPow5(
mp_int *p = base;
int n13 = n / 13;
int r = n % 13;
+ mp_err err = MP_OKAY;
if (r != 0) {
- mp_mul_d(p, dpow5[r], result);
+ err = mp_mul_d(p, dpow5[r], result);
p = result;
}
r = 0;
- while (n13 != 0) {
+ while ((err == MP_OKAY) && (n13 != 0)) {
if (n13 & 1) {
- mp_mul(p, pow5_13+r, result);
+ err = mp_mul(p, pow5_13+r, result);
p = result;
}
n13 >>= 1;
++r;
}
- if (p != result) {
- mp_copy(p, result);
+ if ((err == MP_OKAY) && (p != result)) {
+ err = mp_copy(p, result);
}
+ return err;
}
/*
@@ -2346,13 +2495,13 @@ FormatInfAndNaN(
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
- retval = ckalloc(9);
+ retval = (char *)ckalloc(9);
strcpy(retval, "Infinity");
if (endPtr) {
*endPtr = retval + 8;
}
} else {
- retval = ckalloc(4);
+ retval = (char *)ckalloc(4);
strcpy(retval, "NaN");
if (endPtr) {
*endPtr = retval + 3;
@@ -2383,7 +2532,7 @@ FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
- char *retval = ckalloc(2);
+ char *retval = (char *)ckalloc(2);
strcpy(retval, "0");
if (endPtr) {
@@ -2564,9 +2713,8 @@ ComputeScale(
static inline void
SetPrecisionLimits(
- int convType, /* Type of conversion: TCL_DD_SHORTEST,
- * TCL_DD_STEELE0, TCL_DD_E_FMT,
- * TCL_DD_F_FMT. */
+ int flags, /* Type of conversion: TCL_DD_SHORTEST,
+ * 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). */
@@ -2576,13 +2724,7 @@ SetPrecisionLimits(
int *iLim1Ptr) /* OUT: Number of digits of significance if
* the quick method is used. */
{
- switch (convType) {
- case TCL_DD_SHORTEST0:
- case TCL_DD_STEELE0:
- *iLimPtr = *iLim1Ptr = -1;
- *iPtr = 18;
- *ndigitsPtr = 0;
- break;
+ switch (flags & TCL_DD_CONVERSION_TYPE_MASK) {
case TCL_DD_E_FORMAT:
if (*ndigitsPtr <= 0) {
*ndigitsPtr = 1;
@@ -2598,10 +2740,10 @@ SetPrecisionLimits(
}
break;
default:
- *iPtr = -1;
- *iLimPtr = -1;
- *iLim1Ptr = -1;
- Tcl_Panic("impossible conversion type in TclDoubleDigits");
+ *iLimPtr = *iLim1Ptr = -1;
+ *iPtr = 18;
+ *ndigitsPtr = 0;
+ break;
}
}
@@ -2885,7 +3027,7 @@ QuickConversion(
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 */
+ * TCL_DD_SHORTEST */
int len, /* Length of the return value. */
int ilim, /* Number of digits to store. */
int ilim1, /* Number of digits to store if we misguessed
@@ -2936,7 +3078,7 @@ QuickConversion(
* Handle the peculiar case where the result has no significant digits.
*/
- retval = ckalloc(len + 1);
+ retval = (char *)ckalloc(len + 1);
if (ilim == 0) {
d = d - 5.;
if (d > eps.d) {
@@ -2956,7 +3098,7 @@ QuickConversion(
* Format the digit string.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt);
} else {
end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt);
@@ -3031,8 +3173,6 @@ CastOutPowersOf2(
static inline 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. */
@@ -3049,7 +3189,7 @@ ShorteningInt64Conversion(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
@@ -3099,7 +3239,7 @@ ShorteningInt64Conversion(
*/
if (b < mplus || (b == mplus
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
+ && (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
@@ -3128,7 +3268,7 @@ ShorteningInt64Conversion(
*/
if (b > S - mminus || (b == S - mminus
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
+ && (dPtr->w.word1 & 1) == 0)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
@@ -3199,9 +3339,6 @@ ShorteningInt64Conversion(
static inline 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. */
@@ -3215,7 +3352,7 @@ StrictInt64Conversion(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
@@ -3346,9 +3483,6 @@ ShouldBankerRoundUpToNextPowD(
mp_int *b, /* Numerator of the fraction. */
mp_int *m, /* Numerator of the rounding tolerance. */
int sd, /* Common denominator is 2**(sd*MP_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. */
{
@@ -3360,8 +3494,7 @@ ShouldBankerRoundUpToNextPowD(
* 2**(MP_DIGIT_BIT*sd)
*/
- mp_add(b, m, temp);
- if (temp->used <= sd) { /* Too few digits to be > s */
+ if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) { /* Too few digits to be > s */
return 0;
}
if (temp->used > sd+1 || temp->dp[sd] > 1) {
@@ -3374,10 +3507,6 @@ ShouldBankerRoundUpToNextPowD(
return 1;
}
}
- if (convType == TCL_DD_STEELE0) {
- /* Biased rounding. */
- return 0;
- }
return isodd;
}
@@ -3407,8 +3536,6 @@ ShouldBankerRoundUpToNextPowD(
static inline 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. */
@@ -3425,7 +3552,7 @@ ShorteningBignumConversionPowD(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
@@ -3435,23 +3562,31 @@ ShorteningBignumConversionPowD(
int i; /* Index in the output buffer. */
mp_int temp;
int r1;
+ mp_err err = MP_OKAY;
/*
* b = bw * 2**b2 * 5**b5
* mminus = 5**m5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_init_set(&mminus, 1);
- MulPow5(&b, b5, &b);
- mp_mul_2d(&b, b2, &b);
+ if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
+ return NULL;
+ }
+ if (mp_init_set(&mminus, 1) != MP_OKAY) {
+ mp_clear(&b);
+ return NULL;
+ }
+ err = MulPow5(&b, b5, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, b2, &b);
+ }
/*
* Adjust if the logarithm was guessed wrong.
*/
- if (b.used <= sd) {
- mp_mul_d(&b, 10, &b);
+ if ((err == MP_OKAY) && (b.used <= sd)) {
+ err = mp_mul_d(&b, 10, &b);
++m2plus; ++m2minus; ++m5;
ilim = ilim1;
--k;
@@ -3462,13 +3597,21 @@ ShorteningBignumConversionPowD(
* mplus = 5**m5 * 2**m2plus
*/
- mp_mul_2d(&mminus, m2minus, &mminus);
- MulPow5(&mminus, m5, &mminus);
- if (m2plus > m2minus) {
- mp_init_copy(&mplus, &mminus);
- mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, m2minus, &mminus);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&mminus, m5, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_init_copy(&mplus, &mminus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ }
+ }
+ if (err == MP_OKAY) {
+ err = mp_init(&temp);
}
- mp_init(&temp);
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
@@ -3494,7 +3637,7 @@ ShorteningBignumConversionPowD(
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)) {
+ && (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
@@ -3522,7 +3665,7 @@ ShorteningBignumConversionPowD(
* number?
*/
- if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType,
+ if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd,
dPtr->w.word1 & 1, &temp)) {
if (digit == 9) {
*s++ = '9';
@@ -3550,10 +3693,14 @@ ShorteningBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
- mp_mul_d(&mminus, 10, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mminus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&b, 10, &b);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&mminus, 10, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mminus, m2plus-m2minus, &mplus);
}
++i;
}
@@ -3572,7 +3719,7 @@ ShorteningBignumConversionPowD(
if (endPtr) {
*endPtr = s;
}
- return retval;
+ return (err == MP_OKAY) ? retval : NULL;
}
/*
@@ -3599,9 +3746,6 @@ ShorteningBignumConversionPowD(
static inline 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. */
@@ -3615,33 +3759,36 @@ StrictBignumConversionPowD(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)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;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- MulPow5(&b, b5, &b);
- mp_mul_2d(&b, b2, &b);
+ if (mp_init_u64(&b, bw) != MP_OKAY) {
+ return NULL;
+ }
+ err = MulPow5(&b, b5, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, b2, &b);
+ }
/*
* Adjust if the logarithm was guessed wrong.
*/
- if (b.used <= sd) {
- mp_mul_d(&b, 10, &b);
+ if ((err == MP_OKAY) && (b.used <= sd)) {
+ err = mp_mul_d(&b, 10, &b);
ilim = ilim1;
--k;
}
- mp_init(&temp);
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
@@ -3649,7 +3796,7 @@ StrictBignumConversionPowD(
*/
i = 1;
- for (;;) {
+ while (err == MP_OKAY) {
if (b.used <= sd) {
digit = 0;
} else {
@@ -3681,7 +3828,7 @@ StrictBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
+ err = mp_mul_d(&b, 10, &b);
++i;
}
@@ -3690,7 +3837,7 @@ StrictBignumConversionPowD(
* string.
*/
- mp_clear_multi(&b, &temp, NULL);
+ mp_clear(&b);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -3723,15 +3870,13 @@ ShouldBankerRoundUp(
int r = mp_cmp_mag(twor, S);
switch (r) {
- case MP_LT:
- return 0;
case MP_EQ:
return isodd;
case MP_GT:
return 1;
+ default:
+ return 0;
}
- Tcl_Panic("in ShouldBankerRoundUp, trichotomy fails!");
- return 0;
}
/*
@@ -3754,34 +3899,28 @@ ShouldBankerRoundUpToNext(
* 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. */
+ int isodd) /* 1 if the integer significand is odd. */
{
int r;
+ mp_int temp;
/*
* 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) {
- case MP_LT:
+ if ((mp_init(&temp) != MP_OKAY) || (mp_add(b, m, &temp) != MP_OKAY)) {
return 0;
+ }
+ r = mp_cmp_mag(&temp, S);
+ mp_clear(&temp);
+ switch(r) {
case MP_EQ:
- if (convType == TCL_DD_STEELE0) {
- return 0;
- } else {
- return isodd;
- }
+ return isodd;
case MP_GT:
return 1;
+ default:
+ return 0;
}
- Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!");
- return 0;
}
/*
@@ -3805,7 +3944,6 @@ ShouldBankerRoundUpToNext(
static inline 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. */
@@ -3817,7 +3955,7 @@ ShorteningBignumConversion(
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char *retval = ckalloc(len+1);
+ char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
@@ -3826,27 +3964,36 @@ ShorteningBignumConversion(
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;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_mul_2d(&b, b2, &b);
- mp_init_set(&S, 1);
- MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
+ if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
+ return NULL;
+ }
+ err = mp_mul_2d(&b, b2, &b);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&S, 1);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&S, s5, &S);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&S, s2, &S);
+ }
/*
* 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);
+ if ((err == MP_OKAY) && (mp_cmp_mag(&b, &S) == MP_LT)) {
+ err = mp_mul_d(&b, 10, &b);
minit = 10;
ilim =ilim1;
--k;
@@ -3856,22 +4003,29 @@ ShorteningBignumConversion(
* mminus = 2**m2minus * 5**m5
*/
- mp_init_set(&mminus, minit);
- mp_mul_2d(&mminus, m2minus, &mminus);
- if (m2plus > m2minus) {
- mp_init_copy(&mplus, &mminus);
- mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&mminus, minit);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, m2minus, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_init_copy(&mplus, &mminus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ }
}
- mp_init(&temp);
/*
* Loop through the digits.
*/
- mp_init(&dig);
+ if (err == MP_OKAY) {
+ err = mp_init(&dig);
+ }
i = 1;
- for (;;) {
- mp_div(&b, &S, &dig, &b);
+ while (err == MP_OKAY) {
+ err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
@@ -3883,9 +4037,8 @@ ShorteningBignumConversion(
*/
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)) {
- mp_mul_2d(&b, 1, &b);
+ if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) {
+ err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
++digit;
if (digit == 10) {
@@ -3903,8 +4056,8 @@ ShorteningBignumConversion(
* commit to rounding up to the next higher digit?
*/
- if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType,
- dPtr->w.word1 & 1, &temp)) {
+ if (ShouldBankerRoundUpToNext(&b, &mminus, &S,
+ dPtr->w.word1 & 1)) {
++digit;
if (digit == 10) {
*s++ = '9';
@@ -3920,8 +4073,8 @@ ShorteningBignumConversion(
*/
*s++ = '0' + digit;
- if (i == ilim) {
- mp_mul_2d(&b, 1, &b);
+ if ((err == MP_OKAY) && (i == ilim)) {
+ err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
@@ -3932,17 +4085,21 @@ ShorteningBignumConversion(
* Advance to the next digit.
*/
- if (s5 > 0) {
+ if ((err == MP_OKAY) && (s5 > 0)) {
/*
* Can possibly shorten the denominator.
*/
- mp_mul_2d(&b, 1, &b);
- mp_mul_2d(&mminus, 1, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mplus, 1, &mplus);
+ err = mp_mul_2d(&b, 1, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, 1, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mplus, 1, &mplus);
+ }
+ if (err == MP_OKAY) {
+ err = mp_div_d(&S, 5, &S, NULL);
}
- mp_div_d(&S, 5, &S, NULL);
--s5;
/*
@@ -3972,11 +4129,13 @@ ShorteningBignumConversion(
* 10**42 16 trips
* thereafter no gain.
*/
- } else {
- mp_mul_d(&b, 10, &b);
- mp_mul_d(&mminus, 10, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mplus, 10, &mplus);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_d(&b, 10, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&mminus, 10, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mplus, 10, &mplus);
}
}
@@ -3991,7 +4150,7 @@ ShorteningBignumConversion(
if (m2plus > m2minus) {
mp_clear(&mplus);
}
- mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL);
+ mp_clear_multi(&b, &mminus, &dig, &S, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4020,8 +4179,6 @@ ShorteningBignumConversion(
static inline 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. */
@@ -4032,34 +4189,45 @@ StrictBignumConversion(
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char *retval = ckalloc(len+1);
+ char *retval = (char *)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;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
- mp_init_multi(&temp, &dig, NULL);
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_mul_2d(&b, b2, &b);
- mp_init_set(&S, 1);
- MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
+ if (mp_init(&dig) != MP_OKAY) {
+ return NULL;
+ }
+ if (mp_init_u64(&b, bw) != MP_OKAY) {
+ mp_clear(&dig);
+ return NULL;
+ }
+ err = mp_mul_2d(&b, b2, &b);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&S, 1);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&S, s5, &S);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&S, s2, &S);
+ }
+ }
/*
* 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);
+ if ((mp_cmp_mag(&b, &S) == MP_LT) && (mp_mul_d(&b, 10, &b) == MP_OKAY)) {
ilim =ilim1;
--k;
}
@@ -4069,7 +4237,7 @@ StrictBignumConversion(
*/
i = 0;
- mp_div(&b, &S, &dig, &b);
+ err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
@@ -4081,12 +4249,11 @@ StrictBignumConversion(
*s++ = '0' + digit;
if (++i >= ilim) {
- mp_mul_2d(&b, 1, &b);
- if (ShouldBankerRoundUp(&b, &S, digit&1)) {
+ if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
} else {
- for (;;) {
+ while (err == MP_OKAY) {
/*
* Shift by a group of digits.
*/
@@ -4096,16 +4263,20 @@ StrictBignumConversion(
g = DIGIT_GROUP;
}
if (s5 >= g) {
- mp_div_d(&S, dpow5[g], &S, NULL);
+ err = mp_div_d(&S, dpow5[g], &S, NULL);
s5 -= g;
} else if (s5 > 0) {
- mp_div_d(&S, dpow5[s5], &S, NULL);
- mp_mul_d(&b, dpow5[g - s5], &b);
+ err = mp_div_d(&S, dpow5[s5], &S, NULL);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&b, dpow5[g - s5], &b);
+ }
s5 = 0;
} else {
- mp_mul_d(&b, dpow5[g], &b);
+ err = mp_mul_d(&b, dpow5[g], &b);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, g, &b);
}
- mp_mul_2d(&b, g, &b);
/*
* As with the shortening bignum conversion, it's possible at this
@@ -4119,8 +4290,8 @@ StrictBignumConversion(
* Extract the next group of digits.
*/
- mp_div(&b, &S, &dig, &b);
- if (dig.used > 1) {
+
+ if ((err != MP_OKAY) || (mp_div(&b, &S, &dig, &b) != MP_OKAY) || (dig.used > 1)) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
@@ -4137,8 +4308,7 @@ StrictBignumConversion(
*/
if (i == ilim) {
- mp_mul_2d(&b, 1, &b);
- if (ShouldBankerRoundUp(&b, &S, digit&1)) {
+ if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
break;
@@ -4155,7 +4325,7 @@ StrictBignumConversion(
* string.
*/
- mp_clear_multi(&b, &S, &temp, &dig, NULL);
+ mp_clear_multi(&b, &S, &dig, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4191,22 +4361,13 @@ StrictBignumConversion(
* 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'
- * 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
+ * TCL_DD_E_FORMAT|TCL_DD_SHORTEST 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.
@@ -4217,7 +4378,7 @@ StrictBignumConversion(
* 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
+ * TCL_DD_F_FORMAT|TCL_DD_SHORTEST 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.
@@ -4250,10 +4411,6 @@ TclDoubleDigits(
* 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, 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 */
@@ -4321,18 +4478,18 @@ TclDoubleDigits(
* 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.
+ * shortest, 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
+ * guessed correctly. This is -1 for shortest (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
+ * been guessed 1 too high. This, too, is -1 for shortest,
+ * and 'ndigits' for E format, but it's 'ndigits-1' for F
* format.
*/
- SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1);
+ SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1);
/*
* Try to do low-precision conversion in floating point rather than
@@ -4358,7 +4515,7 @@ TclDoubleDigits(
* denominator.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
int m2minus = b2;
int m2plus;
int m5 = b5;
@@ -4405,7 +4562,7 @@ TclDoubleDigits(
* [1.0e-3 .. 1.0e+24]).
*/
- return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus,
+ return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus,
m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
@@ -4424,7 +4581,7 @@ TclDoubleDigits(
m2minus += delta;
s2 += delta;
}
- return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5,
+ return ShorteningBignumConversionPowD(&d, bw, b2, b5,
m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1,
decpt, endPtr);
} else {
@@ -4433,7 +4590,7 @@ TclDoubleDigits(
* arithmetic for the conversion.
*/
- return ShorteningBignumConversion(&d, convType, bw, b2, m2plus,
+ return ShorteningBignumConversion(&d, bw, b2, m2plus,
m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
}
} else {
@@ -4461,7 +4618,7 @@ TclDoubleDigits(
* operations.
*/
- return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k,
+ return StrictInt64Conversion(bw, b2, b5, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
@@ -4478,7 +4635,7 @@ TclDoubleDigits(
b2 += delta;
s2 += delta;
}
- return StrictBignumConversionPowD(&d, convType, bw, b2, b5,
+ return StrictBignumConversionPowD(bw, b2, b5,
s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
@@ -4488,7 +4645,7 @@ TclDoubleDigits(
* fewer mp_int divisions.
*/
- return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k,
+ return StrictBignumConversion(bw, b2, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
}
}
@@ -4526,6 +4683,7 @@ TclInitDoubleConversion(void)
Tcl_WideUInt iv;
} bitwhack;
#endif
+ mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
@@ -4582,16 +4740,19 @@ TclInitDoubleConversion(void)
*/
for (i=0; i<9; ++i) {
- mp_init(pow5 + i);
+ err = err || mp_init(pow5 + i);
}
- mp_set(pow5, 5);
+ mp_set_u64(pow5, 5);
for (i=0; i<8; ++i) {
- mp_sqr(pow5+i, pow5+i+1);
+ err = err || mp_sqr(pow5+i, pow5+i+1);
}
- mp_init_set_int(pow5_13, 1220703125);
+ err = err || mp_init_u64(pow5_13, 1220703125);
for (i = 1; i < 5; ++i) {
- mp_init(pow5_13 + i);
- mp_sqr(pow5_13 + i - 1, pow5_13 + i);
+ err = err || mp_init(pow5_13 + i);
+ err = err || mp_sqr(pow5_13 + i - 1, pow5_13 + i);
+ }
+ if (err != MP_OKAY) {
+ Tcl_Panic("out of memory");
}
/*
@@ -4679,16 +4840,18 @@ int
Tcl_InitBignumFromDouble(
Tcl_Interp *interp, /* For error message. */
double d, /* Number to convert. */
- mp_int *b) /* Place to store the result. */
+ void *big) /* Place to store the result. */
{
double fract;
int expt;
+ mp_err err;
+ mp_int *b = (mp_int *)big;
/*
* Infinite values can't convert to bignum.
*/
- if (TclIsInfinite(d)) {
+ if (isinf(d)) {
if (interp != NULL) {
const char *s = "integer value too large to represent";
@@ -4698,21 +4861,26 @@ Tcl_InitBignumFromDouble(
return TCL_ERROR;
}
- fract = frexp(d,&expt);
+ fract = frexp(d, &expt);
if (expt <= 0) {
- mp_init(b);
+ err = mp_init(b);
mp_zero(b);
} else {
- Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
+ Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits);
int shift = expt - mantBits;
- TclBNInitBignumFromWideInt(b, w);
- if (shift < 0) {
- mp_div_2d(b, -shift, b, NULL);
+ err = mp_init_i64(b, w);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift < 0) {
+ err = mp_div_2d(b, -shift, b, NULL);
} else if (shift > 0) {
- mp_mul_2d(b, shift, b);
+ err = mp_mul_2d(b, shift, b);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
return TCL_OK;
}
@@ -4733,11 +4901,13 @@ Tcl_InitBignumFromDouble(
double
TclBignumToDouble(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
mp_int b;
int bits, shift, i, lsb;
double r;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
/*
@@ -4766,11 +4936,13 @@ TclBignumToDouble(
* 'rounded to even'.
*/
- mp_init(&b);
- if (shift == 0) {
- mp_copy(a, &b);
+ err = mp_init(&b);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift == 0) {
+ err = mp_copy(a, &b);
} else if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
lsb = mp_cnt_lsb(a);
if (lsb == -1-shift) {
@@ -4779,12 +4951,12 @@ TclBignumToDouble(
* Round to even
*/
- mp_div_2d(a, -shift, &b, NULL);
- if (mp_isodd(&b)) {
+ err = mp_div_2d(a, -shift, &b, NULL);
+ if ((err == MP_OKAY) && mp_isodd(&b)) {
if (mp_isneg(&b)) {
- mp_sub_d(&b, 1, &b);
+ err = mp_sub_d(&b, 1, &b);
} else {
- mp_add_d(&b, 1, &b);
+ err = mp_add_d(&b, 1, &b);
}
}
} else {
@@ -4793,13 +4965,15 @@ TclBignumToDouble(
* Ordinary rounding
*/
- mp_div_2d(a, -1-shift, &b, NULL);
- if (mp_isneg(&b)) {
- mp_sub_d(&b, 1, &b);
+ err = mp_div_2d(a, -1-shift, &b, NULL);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (mp_isneg(&b)) {
+ err = mp_sub_d(&b, 1, &b);
} else {
- mp_add_d(&b, 1, &b);
+ err = mp_add_d(&b, 1, &b);
}
- mp_div_2d(&b, 1, &b, NULL);
+ err = mp_div_2d(&b, 1, &b, NULL);
}
}
@@ -4807,8 +4981,11 @@ TclBignumToDouble(
* Accumulate the result, one mp_digit at a time.
*/
+ if (err != MP_OKAY) {
+ return 0.0;
+ }
r = 0.0;
- for (i=b.used-1 ; i>=0 ; --i) {
+ for (i = b.used-1; i>=0; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
@@ -4846,14 +5023,16 @@ TclBignumToDouble(
double
TclCeil(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
- mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
- mp_neg(a, &b);
+ err = mp_init(&b);
+ if ((err == MP_OKAY) && mp_isneg(a)) {
+ err = mp_neg(a, &b);
r = -TclFloor(&b);
} else {
int bits = mp_count_bits(a);
@@ -4863,19 +5042,26 @@ TclCeil(
} else {
int i, exact = 1, shift = mantBits - bits;
- if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift > 0) {
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
mp_int d;
- mp_init(&d);
- mp_div_2d(a, -shift, &b, &d);
+ err = mp_init(&d);
+ if (err == MP_OKAY) {
+ err = mp_div_2d(a, -shift, &b, &d);
+ }
exact = mp_iszero(&d);
mp_clear(&d);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
+ }
+ if ((err == MP_OKAY) && !exact) {
+ err = mp_add_d(&b, 1, &b);
}
- if (!exact) {
- mp_add_d(&b, 1, &b);
+ if (err != MP_OKAY) {
+ return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
@@ -4903,14 +5089,16 @@ TclCeil(
double
TclFloor(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
- mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
- mp_neg(a, &b);
+ err = mp_init(&b);
+ if ((err == MP_OKAY) && mp_isneg(a)) {
+ err = mp_neg(a, &b);
r = -TclCeil(&b);
} else {
int bits = mp_count_bits(a);
@@ -4921,11 +5109,14 @@ TclFloor(
int i, shift = mantBits - bits;
if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
- mp_div_2d(a, -shift, &b, NULL);
+ err = mp_div_2d(a, -shift, &b, NULL);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
+ }
+ if (err != MP_OKAY) {
+ return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
@@ -4967,6 +5158,7 @@ BignumToBiasedFrExp(
int shift;
int i;
double r;
+ mp_err err = MP_OKAY;
/*
* Determine how many bits we need, and extract that many from the input.
@@ -4975,13 +5167,15 @@ BignumToBiasedFrExp(
bits = mp_count_bits(a);
shift = mantBits - 2 - bits;
- mp_init(&b);
+ if (mp_init(&b)) {
+ return 0.0;
+ }
if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
- mp_div_2d(a, -shift, &b, NULL);
+ err = mp_div_2d(a, -shift, &b, NULL);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
}
/*
@@ -4989,8 +5183,10 @@ BignumToBiasedFrExp(
*/
r = 0.0;
- for (i=b.used-1; i>=0; --i) {
- r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
+ if (err == MP_OKAY) {
+ for (i=b.used-1; i>=0; --i) {
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
+ }
}
mp_clear(&b);
@@ -5038,7 +5234,7 @@ Pow10TimesFrExp(
* Multiply by 10**exponent.
*/
- retval = frexp(retval * pow10vals[exponent&0xF], &j);
+ retval = frexp(retval * pow10vals[exponent & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
@@ -5129,23 +5325,23 @@ TclFormatNaN(
#else
union {
double dv;
- Tcl_WideUInt iv;
+ uint64_t iv;
} bitwhack;
bitwhack.dv = value;
if (n770_fp) {
bitwhack.iv = Nokia770Twiddle(bitwhack.iv);
}
- if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
- bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63);
+ if (bitwhack.iv & (UINT64_C(1) << 63)) {
+ bitwhack.iv &= ~ (UINT64_C(1) << 63);
*buffer++ = '-';
}
*buffer++ = 'N';
*buffer++ = 'a';
*buffer++ = 'N';
- bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1;
+ bitwhack.iv &= ((UINT64_C(1)) << 51) - 1;
if (bitwhack.iv != 0) {
- sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv);
+ sprintf(buffer, "(%" PRIx64 ")", bitwhack.iv);
} else {
*buffer = '\0';
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index b109808..723d2e5 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -27,26 +27,18 @@
* internal representation to keep track of how much space is used vs.
* allocated.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
*
* 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 "tommath.h"
+#include "tclTomMath.h"
#include "tclStringRep.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
-
+#include "assert.h"
/*
* Prototypes for functions defined later in this file:
*/
@@ -76,13 +68,41 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int numChars);
static int UnicodeLength(const Tcl_UniChar *unicode);
+#if !defined(TCL_NO_DEPRECATED)
+static int UTF16Length(const unsigned short *unicode);
+#endif
static void UpdateStringOfString(Tcl_Obj *objPtr);
+#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED)
+static void DupUTF16StringInternalRep(Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr);
+static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfUTF16String(Tcl_Obj *objPtr);
+#endif
+
+#define ISCONTINUATION(bytes) (\
+ ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \
+ && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80))))
+
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
*/
+#if TCL_UTF_MAX < 4
+
+#define tclUniCharStringType tclStringType
+#define GET_UNICHAR_STRING GET_STRING
+#define UniCharString String
+#define UNICHAR_STRING_MAXCHARS STRING_MAXCHARS
+#define uniCharStringAlloc stringAlloc
+#define uniCharStringRealloc stringRealloc
+#define uniCharStringAttemptAlloc stringAttemptAlloc
+#define uniCharStringAttemptRealloc stringAttemptRealloc
+#define uniCharStringCheckLimits stringCheckLimits
+#define SET_UNICHAR_STRING SET_STRING
+#define UNICHAR_STRING_SIZE STRING_SIZE
+
const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
@@ -90,7 +110,149 @@ const Tcl_ObjType tclStringType = {
UpdateStringOfString, /* updateStringProc */
SetStringFromAny /* setFromAnyProc */
};
-
+
+#else
+
+#ifndef TCL_NO_DEPRECATED
+const Tcl_ObjType tclStringType = {
+ "string", /* name */
+ FreeStringInternalRep, /* freeIntRepPro */
+ DupUTF16StringInternalRep, /* dupIntRepProc */
+ UpdateStringOfUTF16String, /* updateStringProc */
+ SetUTF16StringFromAny /* setFromAnyProc */
+};
+#endif
+
+const Tcl_ObjType tclUniCharStringType = {
+ "utf32string", /* name */
+ FreeStringInternalRep, /* freeIntRepPro */
+ DupStringInternalRep, /* dupIntRepProc */
+ UpdateStringOfString, /* updateStringProc */
+ SetStringFromAny /* setFromAnyProc */
+};
+
+typedef struct {
+ int numChars; /* The number of chars in the string. -1 means
+ * this value has not been calculated. >= 0
+ * means that there is a valid Unicode rep, or
+ * that the number of UTF bytes == the number
+ * of chars. */
+ int allocated; /* The amount of space actually allocated for
+ * the UTF string (minus 1 byte 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[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
+ * of this field depends on the 'maxChars'
+ * field above. */
+} UniCharString;
+
+#define UNICHAR_STRING_MAXCHARS \
+ (int)(((size_t)UINT_MAX - offsetof(UniCharString, unicode))/sizeof(Tcl_UniChar) - 1)
+#define UNICHAR_STRING_SIZE(numChars) \
+ (offsetof(UniCharString, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
+#define uniCharStringCheckLimits(numChars) \
+ do { \
+ if ((numChars) < 0 || (numChars) > UNICHAR_STRING_MAXCHARS) { \
+ Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
+ UNICHAR_STRING_MAXCHARS); \
+ } \
+ } while (0)
+#define uniCharStringAttemptAlloc(numChars) \
+ (UniCharString *) attemptckalloc(UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringAlloc(numChars) \
+ (UniCharString *) ckalloc(UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringRealloc(ptr, numChars) \
+ (UniCharString *) ckrealloc((ptr), UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringAttemptRealloc(ptr, numChars) \
+ (UniCharString *) attemptckrealloc((ptr), UNICHAR_STRING_SIZE(numChars))
+#define GET_UNICHAR_STRING(objPtr) \
+ ((UniCharString *) (objPtr)->internalRep.twoPtrValue.ptr1)
+#define SET_UNICHAR_STRING(objPtr, stringPtr) \
+ ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
+
+
+#ifndef TCL_NO_DEPRECATED
+static void
+DupUTF16StringInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
+ * an internal rep of type "String". */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
+ * currently have an internal rep.*/
+{
+ String *srcStringPtr = GET_STRING(srcPtr);
+ size_t size = offsetof(String, unicode) + (((srcStringPtr->allocated) + 1U) * sizeof(unsigned short));
+ String *copyStringPtr = (String *)ckalloc(size);
+ memcpy(copyStringPtr, srcStringPtr, size);
+
+ SET_STRING(copyPtr, copyStringPtr);
+ copyPtr->typePtr = &tclStringType;
+}
+
+static int
+SetUTF16StringFromAny(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ if (!TclHasInternalRep(objPtr, &tclStringType)) {
+ Tcl_DString ds;
+
+ /*
+ * Convert whatever we have into an untyped value. Just A String.
+ */
+
+ (void) TclGetString(objPtr);
+ TclFreeInternalRep(objPtr);
+
+ /*
+ * Create a basic String internalrep that just points to the UTF-8 string
+ * already in place at objPtr->bytes.
+ */
+
+ Tcl_DStringInit(&ds);
+ unsigned short *utf16string = Tcl_UtfToChar16DString(objPtr->bytes, objPtr->length, &ds);
+ int size = Tcl_DStringLength(&ds);
+ String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + size);
+
+ memcpy(stringPtr->unicode, utf16string, size);
+ Tcl_DStringFree(&ds);
+ size /= sizeof(unsigned short);
+ stringPtr->unicode[size] = 0;
+
+ stringPtr->numChars = size;
+ stringPtr->allocated = size;
+ stringPtr->maxChars = size;
+ stringPtr->hasUnicode = 1;
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+ }
+ return TCL_OK;
+}
+
+static void
+UpdateStringOfUTF16String(
+ Tcl_Obj *objPtr) /* Object with string rep to update. */
+{
+ Tcl_DString ds;
+ String *stringPtr = GET_STRING(objPtr);
+
+ Tcl_DStringInit(&ds);
+ const char *string = Tcl_Char16ToUtfDString(stringPtr->unicode, stringPtr->numChars, &ds);
+
+ char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U);
+ memcpy(bytes, string, Tcl_DStringLength(&ds));
+ bytes[Tcl_DStringLength(&ds)] = 0;
+ objPtr->bytes = bytes;
+ objPtr->length = Tcl_DStringLength(&ds);
+ Tcl_DStringFree(&ds);
+}
+#endif
+
+#endif
+
/*
* TCL STRING GROWTH ALGORITHM
*
@@ -141,11 +303,11 @@ GrowStringBuffer(
* flag || objPtr->bytes != NULL
*/
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
char *ptr = NULL;
int attempt;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
@@ -188,10 +350,10 @@ GrowUnicodeBuffer(
* Pre-conditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->maxChars
- * needed < STRING_MAXCHARS
+ * needed < UNICHAR_STRING_MAXCHARS
*/
- String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
+ UniCharString *ptr = NULL, *stringPtr = GET_UNICHAR_STRING(objPtr);
int attempt;
if (stringPtr->maxChars > 0) {
@@ -199,9 +361,9 @@ GrowUnicodeBuffer(
* Subsequent appends - apply the growth algorithm.
*/
- if (needed <= STRING_MAXCHARS / 2) {
+ if (needed <= UNICHAR_STRING_MAXCHARS / 2) {
attempt = 2 * needed;
- ptr = stringAttemptRealloc(stringPtr, attempt);
+ ptr = uniCharStringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
/*
@@ -209,13 +371,13 @@ GrowUnicodeBuffer(
* overflow into invalid argument values for attempt.
*/
- unsigned int limit = STRING_MAXCHARS - needed;
+ unsigned int limit = UNICHAR_STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
+ TCL_MIN_UNICHAR_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
- ptr = stringAttemptRealloc(stringPtr, attempt);
+ ptr = uniCharStringAttemptRealloc(stringPtr, attempt);
}
}
if (ptr == NULL) {
@@ -224,11 +386,11 @@ GrowUnicodeBuffer(
*/
attempt = needed;
- ptr = stringRealloc(stringPtr, attempt);
+ ptr = uniCharStringRealloc(stringPtr, attempt);
}
stringPtr = ptr;
stringPtr->maxChars = attempt;
- SET_STRING(objPtr, stringPtr);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
}
/*
@@ -350,10 +512,8 @@ Tcl_DbNewStringObj(
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
- 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewStringObj(bytes, length);
}
@@ -379,7 +539,7 @@ Tcl_DbNewStringObj(
*/
Tcl_Obj *
-Tcl_NewUnicodeObj(
+TclNewUnicodeObj(
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* new object. */
int numChars) /* Number of characters in the unicode
@@ -392,6 +552,39 @@ Tcl_NewUnicodeObj(
return objPtr;
}
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+Tcl_Obj *
+Tcl_NewUnicodeObj(
+ const unsigned short *unicode, /* The unicode string used to initialize the
+ * new object. */
+ int numChars) /* Number of characters in the unicode
+ * string. */
+{
+ Tcl_Obj *objPtr;
+
+ TclNewObj(objPtr);
+ TclInvalidateStringRep(objPtr);
+
+ if (numChars < 0) {
+ numChars = UTF16Length(unicode);
+ }
+
+ String *stringPtr = (String *)ckalloc((offsetof(String, unicode)
+ + sizeof(unsigned short)) + numChars * sizeof(unsigned short));
+ memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short));
+ stringPtr->unicode[numChars] = 0;
+
+ stringPtr->numChars = numChars;
+ stringPtr->allocated = numChars;
+ stringPtr->maxChars = numChars;
+ stringPtr->hasUnicode = 1;
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+
+ return objPtr;
+}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -410,11 +603,11 @@ Tcl_NewUnicodeObj(
*/
int
-Tcl_GetCharLength(
+TclGetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int numChars;
/*
@@ -430,13 +623,14 @@ Tcl_GetCharLength(
* Optimize the case where we're really dealing with a bytearray object;
* we don't need to convert to a string to perform the get-length operation.
*
- * NOTE that we do not need the bytearray to be "pure". A ByteArray value
- * with a string rep cannot be trusted to represent the same value as the
- * string rep, but it *can* be trusted to have the same character length
- * as the string rep, which is all this routine cares about.
+ * Starting in Tcl 8.7, we check for a "pure" bytearray, because the
+ * machinery behind that test is using a proper bytearray ObjType. We
+ * could also compute length of an improper bytearray without shimmering
+ * but there's no value in that. We *want* to shimmer an improper bytearray
+ * because improper bytearrays have worthless internal reps.
*/
- if (objPtr->typePtr == &tclByteArrayType) {
+ if (TclIsPureByteArray(objPtr)) {
int length;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
@@ -448,7 +642,7 @@ Tcl_GetCharLength(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
numChars = stringPtr->numChars;
/*
@@ -456,24 +650,52 @@ Tcl_GetCharLength(
*/
if (numChars == -1) {
- TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
+ TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
+ }
+ return numChars;
+}
+
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetCharLength
+int
+Tcl_GetCharLength(
+ Tcl_Obj *objPtr) /* The String object to get the num chars
+ * of. */
+{
+ int numChars;
-#if COMPAT
- if (numChars < objPtr->length) {
- /*
- * 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.
- */
+ /*
+ * Quick, no-shimmer return for short string reps.
+ */
- FillUnicodeRep(objPtr);
- }
-#endif
+ if ((objPtr->bytes) && (objPtr->length < 2)) {
+ /* 0 bytes -> 0 chars; 1 byte -> 1 char */
+ return objPtr->length;
+ }
+
+ /*
+ * Optimize the case where we're really dealing with a bytearray object;
+ * we don't need to convert to a string to perform the get-length operation.
+ *
+ * Starting in Tcl 8.7, we check for a "pure" bytearray, because the
+ * machinery behind that test is using a proper bytearray ObjType. We
+ * could also compute length of an improper bytearray without shimmering
+ * but there's no value in that. We *want* to shimmer an improper bytearray
+ * because improper bytearrays have worthless internal reps.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+
+ (void) Tcl_GetByteArrayFromObj(objPtr, &numChars);
+ } else {
+ Tcl_GetString(objPtr);
+ numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
}
return numChars;
}
-
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -491,17 +713,17 @@ Tcl_GetCharLength(
*----------------------------------------------------------------------
*/
int
-TclCheckEmptyString (
+TclCheckEmptyString(
Tcl_Obj *objPtr)
{
int length = -1;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
- if (TclIsPureList(objPtr)) {
- TclListObjLength(NULL, objPtr, &length);
+ if (TclListObjIsCanonical(objPtr)) {
+ TclListObjLengthM(NULL, objPtr, &length);
return length == 0;
}
@@ -519,10 +741,11 @@ TclCheckEmptyString (
/*
*----------------------------------------------------------------------
*
- * Tcl_GetUniChar/TclGetUCS4 --
+ * Tcl_GetUniChar --
*
* Get the index'th Unicode character from the String object. If index
- * is out of range, the result = 0xFFFD (Tcl_GetUniChar) resp. -1 (TclGetUCS4)
+ * is out of range or it references a low surrogate preceded by a high
+ * surrogate, the result = -1;
*
* Results:
* Returns the index'th Unicode character in the Object.
@@ -533,17 +756,19 @@ TclCheckEmptyString (
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetUniChar
+int
Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
int index) /* Get the index'th Unicode character. */
{
String *stringPtr;
- int length;
+ int ch, length;
if (index < 0) {
- return 0xFFFD;
+ return -1;
}
/*
@@ -554,48 +779,48 @@ Tcl_GetUniChar(
if (TclIsPureByteArray(objPtr)) {
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
- return 0xFFFD;
+ return -1;
}
- return (Tcl_UniChar) bytes[index];
+ return (int) bytes[index];
}
/*
* OK, need to work with the object as a string.
*/
- SetStringFromAny(NULL, objPtr);
+ SetUTF16StringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode == 0) {
- /*
- * If numChars is unknown, compute it.
- */
-
- if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
- }
- if (stringPtr->numChars == objPtr->length) {
- return (unsigned char) objPtr->bytes[index];
- }
- FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
-
if (index >= stringPtr->numChars) {
- return 0xFFFD;
+ return -1;
+ }
+ ch = stringPtr->unicode[index];
+ /* See: bug [11ae2be95dac9417] */
+ if ((ch & 0xF800) == 0xD800) {
+ if (ch & 0x400) {
+ if ((index > 0)
+ && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
+ ch = -1; /* low surrogate preceded by high surrogate */
+ }
+ } else if ((++index < stringPtr->numChars)
+ && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
+ /* high surrogate followed by low surrogate */
+ ch = (((ch & 0x3FF) << 10) |
+ (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+ }
}
- return stringPtr->unicode[index];
+ return ch;
}
+#endif
-#if TCL_UTF_MAX == 4
int
-TclGetUCS4(
+TclGetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
int index) /* Get the index'th Unicode character. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int ch, length;
if (index < 0) {
@@ -621,7 +846,7 @@ TclGetUCS4(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
@@ -629,20 +854,20 @@ TclGetUCS4(
*/
if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
return (unsigned char) objPtr->bytes[index];
}
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
if (index >= stringPtr->numChars) {
return -1;
}
ch = stringPtr->unicode[index];
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
@@ -660,7 +885,6 @@ TclGetUCS4(
#endif
return ch;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -681,18 +905,22 @@ TclGetUCS4(
*----------------------------------------------------------------------
*/
-Tcl_UniChar *
+#undef Tcl_GetUnicodeFromObj
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_GetUnicode
+unsigned short *
Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the unicode string
* for. */
{
- return Tcl_GetUnicodeFromObj(objPtr, NULL);
+ return TclGetUnicodeFromObj(objPtr, NULL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
- * Tcl_GetUnicodeFromObj --
+ * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj --
*
* Get the Unicode form of the String object with length. If the object
* is not already a String object, it will be converted to one. If the
@@ -709,28 +937,74 @@ Tcl_GetUnicode(
*/
Tcl_UniChar *
-Tcl_GetUnicodeFromObj(
+TclGetUnicodeFromObj_(
Tcl_Obj *objPtr, /* The object to find the unicode string
* for. */
int *lengthPtr) /* If non-NULL, the location where the string
* rep's unichar length should be stored. If
* NULL, no length is stored. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ }
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = stringPtr->numChars;
+ }
+ return stringPtr->unicode;
+}
+
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
+unsigned short *
+Tcl_GetUnicodeFromObj(
+ Tcl_Obj *objPtr, /* The object to find the unicode string
+ * for. */
+ int *lengthPtr) /* If non-NULL, the location where the string
+ * rep's unichar length should be stored. If
+ * NULL, no length is stored. */
+{
+ String *stringPtr;
+
+ SetUTF16StringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = stringPtr->numChars;
}
+ return stringPtr->unicode;
+}
+#endif
+
+#if !defined(TCL_NO_DEPRECATED)
+unsigned short *
+TclGetUnicodeFromObj(
+ Tcl_Obj *objPtr, /* The object to find the unicode string
+ * for. */
+ size_t *lengthPtr) /* If non-NULL, the location where the string
+ * rep's unichar length should be stored. If
+ * NULL, no length is stored. */
+{
+ String *stringPtr;
+
+#if TCL_UTF_MAX > 3
+ SetUTF16StringFromAny(NULL, objPtr);
+#else
+ SetStringFromAny(NULL, objPtr);
+#endif
+ stringPtr = GET_STRING(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = stringPtr->numChars;
}
return stringPtr->unicode;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -752,6 +1026,8 @@ Tcl_GetUnicodeFromObj(
*----------------------------------------------------------------------
*/
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetRange
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
@@ -759,7 +1035,53 @@ Tcl_GetRange(
int last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
- String *stringPtr;
+ int length;
+
+ if (first < 0) {
+ first = 0;
+ }
+
+ /*
+ * Optimize the case where we're really dealing with a bytearray object
+ * we don't need to convert to a string to perform the substring operation.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+
+ if (last < 0 || last >= length) {
+ last = length - 1;
+ }
+ if (last < first) {
+ TclNewObj(newObjPtr);
+ return newObjPtr;
+ }
+ return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
+ }
+
+ int numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
+
+ if (last < 0 || last >= numChars) {
+ last = numChars - 1;
+ }
+ if (last < first) {
+ TclNewObj(newObjPtr);
+ return newObjPtr;
+ }
+ const char *begin = Tcl_UtfAtIndex(objPtr->bytes, first);
+ const char *end = Tcl_UtfAtIndex(objPtr->bytes, last + 1);
+ return Tcl_NewStringObj(begin, end - begin);
+}
+#endif
+
+Tcl_Obj *
+TclGetRange(
+ Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
+ int first, /* First index of the range. */
+ int last) /* Last index of the range. */
+{
+ Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
+ UniCharString *stringPtr;
int length;
if (first < 0) {
@@ -789,7 +1111,7 @@ Tcl_GetRange(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
@@ -797,7 +1119,7 @@ Tcl_GetRange(
*/
if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
if (last < 0 || last >= stringPtr->numChars) {
@@ -814,14 +1136,13 @@ Tcl_GetRange(
*/
SetStringFromAny(NULL, newObjPtr);
- stringPtr = GET_STRING(newObjPtr);
+ stringPtr = GET_UNICHAR_STRING(newObjPtr);
stringPtr->numChars = newObjPtr->length;
return newObjPtr;
}
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
-
if (last < 0 || last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
@@ -829,7 +1150,7 @@ Tcl_GetRange(
TclNewObj(newObjPtr);
return newObjPtr;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
@@ -841,7 +1162,7 @@ Tcl_GetRange(
++last;
}
#endif
- return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
+ return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}
/*
@@ -882,7 +1203,7 @@ Tcl_SetStringObj(
* Set the type to NULL and free any internal rep for the old type.
*/
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
/*
* Free any old string rep, then set the string rep to a copy of the
@@ -927,7 +1248,7 @@ Tcl_SetObjLength(
* representation of object, not including
* terminating null byte. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (length < 0) {
/*
@@ -947,7 +1268,7 @@ Tcl_SetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -957,7 +1278,7 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = (char *)ckalloc((unsigned int)length + 1U);
} else {
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, (unsigned int)length + 1U);
@@ -979,10 +1300,10 @@ Tcl_SetObjLength(
* Changing length of pure unicode string.
*/
- stringCheckLimits(length);
+ uniCharStringCheckLimits(length);
if (length > stringPtr->maxChars) {
- stringPtr = stringRealloc(stringPtr, length);
- SET_STRING(objPtr, stringPtr);
+ stringPtr = uniCharStringRealloc(stringPtr, length);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
@@ -1032,7 +1353,7 @@ Tcl_AttemptSetObjLength(
* representation of object, not including
* terminating null byte. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (length < 0) {
/*
@@ -1050,7 +1371,7 @@ Tcl_AttemptSetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -1063,7 +1384,7 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)attemptckalloc((unsigned int)length + 1U);
} else {
newBytes = (char *)attemptckrealloc(objPtr->bytes, (unsigned int)length + 1U);
@@ -1089,15 +1410,15 @@ Tcl_AttemptSetObjLength(
* Changing length of pure unicode string.
*/
- if (length > STRING_MAXCHARS) {
+ if (length > UNICHAR_STRING_MAXCHARS) {
return 0;
}
if (length > stringPtr->maxChars) {
- stringPtr = stringAttemptRealloc(stringPtr, length);
+ stringPtr = uniCharStringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
- SET_STRING(objPtr, stringPtr);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
@@ -1133,20 +1454,55 @@ Tcl_AttemptSetObjLength(
*---------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
- const Tcl_UniChar *unicode, /* The unicode string used to initialize the
+ const unsigned short *unicode, /* The unicode string used to initialize the
* object. */
int numChars) /* Number of characters in the unicode
* string. */
{
- if (Tcl_IsShared(objPtr)) {
- Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
+ String *stringPtr;
+
+ if (numChars < 0) {
+ numChars = UTF16Length(unicode);
}
- TclFreeIntRep(objPtr);
- SetUnicodeObj(objPtr, unicode, numChars);
+
+ /*
+ * Allocate enough space for the String structure + Unicode string.
+ */
+
+ stringCheckLimits(numChars);
+ stringPtr = stringAlloc(numChars);
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+
+ stringPtr->maxChars = numChars;
+ memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned char));
+ stringPtr->unicode[numChars] = 0;
+ stringPtr->numChars = numChars;
+ stringPtr->hasUnicode = 1;
+
+ TclInvalidateStringRep(objPtr);
+ stringPtr->allocated = numChars;
+}
+
+static int
+UTF16Length(
+ const unsigned short *ucs2Ptr)
+{
+ int numChars = 0;
+
+ if (ucs2Ptr) {
+ while (numChars >= 0 && ucs2Ptr[numChars] != 0) {
+ numChars++;
+ }
+ }
+ stringCheckLimits(numChars);
+ return numChars;
}
+#endif
static int
UnicodeLength(
@@ -1159,7 +1515,7 @@ UnicodeLength(
numChars++;
}
}
- stringCheckLimits(numChars);
+ uniCharStringCheckLimits(numChars);
return numChars;
}
@@ -1171,7 +1527,7 @@ SetUnicodeObj(
int numChars) /* Number of characters in the unicode
* string. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
@@ -1181,10 +1537,10 @@ SetUnicodeObj(
* Allocate enough space for the String structure + Unicode string.
*/
- stringCheckLimits(numChars);
- stringPtr = stringAlloc(numChars);
- SET_STRING(objPtr, stringPtr);
- objPtr->typePtr = &tclStringType;
+ uniCharStringCheckLimits(numChars);
+ stringPtr = uniCharStringAlloc(numChars);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclUniCharStringType;
stringPtr->maxChars = numChars;
memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
@@ -1228,7 +1584,7 @@ Tcl_AppendLimitedToObj(
* object to indicate not all available bytes
* at "bytes" were appended. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int toCopy = 0;
int eLen = 0;
@@ -1250,10 +1606,10 @@ Tcl_AppendLimitedToObj(
}
eLen = strlen(ellipsis);
while (eLen > limit) {
- eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
+ eLen = Tcl_UtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
}
- toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes;
+ toCopy = Tcl_UtfPrev(bytes+limit+1-eLen, bytes) - bytes;
}
/*
@@ -1267,8 +1623,14 @@ Tcl_AppendLimitedToObj(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ /* If appended string starts with a continuation byte or a lower surrogate,
+ * force objPtr to unicode representation. See [7f1162a867] */
+ if (bytes && ISCONTINUATION(bytes)) {
+ TclGetUnicodeFromObj_(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ }
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
@@ -1279,7 +1641,7 @@ Tcl_AppendLimitedToObj(
return;
}
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
@@ -1334,13 +1696,13 @@ Tcl_AppendToObj(
*/
void
-Tcl_AppendUnicodeToObj(
+TclAppendUnicodeToObj(
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". */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
@@ -1351,7 +1713,7 @@ Tcl_AppendUnicodeToObj(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* If objPtr has a valid Unicode rep, then append the "unicode" to the
@@ -1359,17 +1721,41 @@ Tcl_AppendUnicodeToObj(
* objPtr's string rep.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
AppendUnicodeToUtfRep(objPtr, unicode, length);
}
}
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
+void
+Tcl_AppendUnicodeToObj(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const unsigned short *unicode, /* The unicode string to append to the
+ * object. */
+ int length) /* Number of chars in "unicode". */
+{
+ String *stringPtr;
+
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
+ }
+
+ if (length == 0) {
+ return;
+ }
+
+ SetUTF16StringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+ stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length);
+ memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length);
+ stringPtr->maxChars = stringPtr->allocated = stringPtr->numChars += length;
+ stringPtr->unicode[stringPtr->numChars] = 0;
+ SET_STRING(objPtr, stringPtr);
+}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -1395,7 +1781,7 @@ Tcl_AppendObjToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int length, numChars, appendNumChars = -1;
const char *bytes;
@@ -1404,18 +1790,18 @@ Tcl_AppendObjToObj(
* that appending nothing to anything leaves that starting anything...
*/
- if (appendObjPtr->bytes == tclEmptyStringRep) {
+ if (appendObjPtr->bytes == &tclEmptyString) {
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.
+ * Note that we only do this when the objects are pure so that the
+ * bytearray faithfully represent the true value; Otherwise appending the
+ * byte arrays together could lose information;
*/
- if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
+ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
* You might expect the code here to be
@@ -1459,7 +1845,7 @@ Tcl_AppendObjToObj(
*/
TclAppendBytesToByteArray(objPtr,
- Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
+ TclGetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
return;
}
@@ -1468,25 +1854,28 @@ Tcl_AppendObjToObj(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
-
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+
+ /* If appended string starts with a continuation byte or a lower surrogate,
+ * force objPtr to unicode representation. See [7f1162a867]
+ * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */
+ if (ISCONTINUATION(TclGetString(appendObjPtr))) {
+ TclGetUnicodeFromObj_(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ }
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
- if (appendObjPtr->typePtr == &tclStringType) {
+ if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
Tcl_UniChar *unicode =
- Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
+ TclGetUnicodeFromObj_(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
@@ -1505,19 +1894,15 @@ Tcl_AppendObjToObj(
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
- if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
- String *appendStringPtr = GET_STRING(appendObjPtr);
+ if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
+ UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
- if (numChars >= 0 && appendNumChars >= 0
-#if COMPAT
- && appendNumChars == length
-#endif
- ) {
+ if (numChars >= 0 && appendNumChars >= 0) {
stringPtr->numChars = numChars + appendNumChars;
}
}
@@ -1545,7 +1930,7 @@ AppendUnicodeToUnicodeRep(
const Tcl_UniChar *unicode, /* String to append. */
int appendNumChars) /* Number of chars of "unicode" to append. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int numChars;
if (appendNumChars < 0) {
@@ -1556,7 +1941,7 @@ AppendUnicodeToUnicodeRep(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* If not enough space has been allocated for the unicode rep, reallocate
@@ -1567,7 +1952,7 @@ AppendUnicodeToUnicodeRep(
*/
numChars = stringPtr->numChars + appendNumChars;
- stringCheckLimits(numChars);
+ uniCharStringCheckLimits(numChars);
if (numChars > stringPtr->maxChars) {
int offset = -1;
@@ -1584,7 +1969,7 @@ AppendUnicodeToUnicodeRep(
}
GrowUnicodeBuffer(objPtr, numChars);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* Relocate unicode if needed; see above.
@@ -1634,21 +2019,13 @@ AppendUnicodeToUtfRep(
const Tcl_UniChar *unicode, /* String to convert to UTF. */
int numChars) /* Number of chars of "unicode" to convert. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
if (stringPtr->numChars != -1) {
stringPtr->numChars += numChars;
}
-
-#if COMPAT
- /*
- * Invalidate the unicode rep.
- */
-
- stringPtr->hasUnicode = 0;
-#endif
}
/*
@@ -1675,7 +2052,7 @@ AppendUtfToUnicodeRep(
const char *bytes, /* String to convert to Unicode. */
int numBytes) /* Number of bytes of "bytes" to convert. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (numBytes == 0) {
return;
@@ -1683,7 +2060,7 @@ AppendUtfToUnicodeRep(
ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1);
TclInvalidateStringRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
stringPtr->allocated = 0;
}
@@ -1711,7 +2088,7 @@ AppendUtfToUtfRep(
const char *bytes, /* String to append. */
int numBytes) /* Number of bytes of "bytes" to append. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int newLength, oldLength;
if (numBytes == 0) {
@@ -1732,7 +2109,7 @@ AppendUtfToUtfRep(
}
newLength = numBytes + oldLength;
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (newLength > stringPtr->allocated) {
int offset = -1;
@@ -2096,6 +2473,25 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if (ch == 'I') {
+ if ((format[1] == '6') && (format[2] == '4')) {
+ format += (step + 2);
+ step = TclUtfToUniChar(format, &ch);
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+#endif
+ } else if ((format[1] == '3') && (format[2] == '2')) {
+ format += (step + 2);
+ step = TclUtfToUniChar(format, &ch);
+ } else {
+ format += step;
+ step = TclUtfToUniChar(format, &ch);
+ }
+ } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j')
+ || (ch == 'L')) {
+ format += step;
+ step = TclUtfToUniChar(format, &ch);
+ useBig = 1;
}
format += step;
@@ -2117,12 +2513,12 @@ Tcl_AppendFormatToObj(
goto errorMsg;
case 's':
if (gotPrecision) {
- numChars = Tcl_GetCharLength(segment);
+ numChars = TclGetCharLength(segment);
if (precision < numChars) {
if (precision < 1) {
TclNewObj(segment);
} else {
- segment = Tcl_GetRange(segment, 0, precision - 1);
+ segment = TclGetRange(segment, 0, precision - 1);
}
numChars = precision;
Tcl_IncrRefCount(segment);
@@ -2138,12 +2534,10 @@ Tcl_AppendFormatToObj(
goto error;
}
length = Tcl_UniCharToUtf(code, buf);
-#if TCL_UTF_MAX > 3
if ((code >= 0xD800) && (length < 3)) {
/* Special case for handling high surrogates. */
length += Tcl_UniCharToUtf(-1, buf + length);
}
-#endif
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
@@ -2151,14 +2545,10 @@ Tcl_AppendFormatToObj(
}
case 'u':
- if (useBig) {
- msg = "unsigned bignum format is invalid";
- errCode = "BADUNSIGNED";
- goto errorMsg;
- }
/* FALLTHRU */
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -2169,53 +2559,58 @@ Tcl_AppendFormatToObj(
mp_int big;
int toAppend, isNegative = 0;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (ch == 'p') {
+ useWide = 1;
+ }
+#endif
if (useBig) {
+ int cmpResult;
if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
- isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+ cmpResult = mp_cmp_d(&big, 0);
+ isNegative = (cmpResult == MP_LT);
+ if (cmpResult == MP_EQ) gotHash = 0;
+ if (ch == 'u') {
+ if (isNegative) {
+ mp_clear(&big);
+ msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
+ goto errorMsg;
+ } else {
+ ch = 'd';
+ }
+ }
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, CHAR_BIT*sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- Tcl_GetWideIntFromObj(NULL, objPtr, &w);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
+ if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &l);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
} else {
- l = Tcl_WideAsLong(w);
+ l = (long) w;
}
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
} else if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
TclNewObj(segment);
@@ -2229,18 +2624,15 @@ Tcl_AppendFormatToObj(
segmentLimit -= 1;
}
- if (gotHash) {
+ if (gotHash || (ch == 'p')) {
switch (ch) {
case 'o':
- Tcl_AppendToObj(segment, "0", 1);
- segmentLimit -= 1;
- precision--;
- break;
- case 'X':
- Tcl_AppendToObj(segment, "0X", 2);
+ Tcl_AppendToObj(segment, "0o", 2);
segmentLimit -= 2;
break;
+ case 'p':
case 'x':
+ case 'X':
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
@@ -2248,6 +2640,14 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+#if TCL_MAJOR_VERSION < 9
+ case 'd':
+ if (gotZero) {
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ }
+ break;
+#endif
}
}
@@ -2258,15 +2658,15 @@ Tcl_AppendFormatToObj(
const char *bytes;
if (useShort) {
- TclNewIntObj(pure, (int) s);
+ TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- pure = Tcl_NewWideIntObj(w);
+ TclNewIntObj(pure, w);
#endif
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
- pure = Tcl_NewLongObj(l);
+ TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
@@ -2298,7 +2698,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2319,6 +2719,7 @@ Tcl_AppendFormatToObj(
case 'u':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -2355,7 +2756,7 @@ Tcl_AppendFormatToObj(
uw /= base;
}
#endif
- } else if (useBig && big.used) {
+ } else if (useBig && !mp_iszero(&big)) {
int leftover = (big.used * MP_DIGIT_BIT) % numBits;
mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
@@ -2384,7 +2785,7 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
TclNewObj(pure);
@@ -2394,7 +2795,7 @@ Tcl_AppendFormatToObj(
while (numDigits--) {
int digitOffset;
- if (useBig && big.used) {
+ if (useBig && !mp_iszero(&big)) {
if (index < big.used && (size_t) shift <
CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
@@ -2428,7 +2829,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2451,6 +2852,8 @@ Tcl_AppendFormatToObj(
break;
}
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
@@ -2519,6 +2922,12 @@ Tcl_AppendFormatToObj(
errCode = "OVERFLOW";
goto errorMsg;
}
+ if (ch == 'A') {
+ char *q = TclGetString(segment) + 1;
+ *q = 'x';
+ q = strchr(q, 'P');
+ if (q) *q = 'p';
+ }
break;
}
default:
@@ -2531,7 +2940,7 @@ Tcl_AppendFormatToObj(
}
if (width>0 && numChars<0) {
- numChars = Tcl_GetCharLength(segment);
+ numChars = TclGetCharLength(segment);
}
if (!gotMinus && width>0) {
if (numChars < width) {
@@ -2687,12 +3096,12 @@ AppendPrintfToObjVA(
* multi-byte characters.
*/
- q = TclUtfPrev(end, bytes);
+ q = Tcl_UtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
end = q;
}
- q = bytes + TCL_UTF_MAX;
+ q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
@@ -2708,33 +3117,49 @@ AppendPrintfToObjVA(
case 'u':
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
seekingConversion = 0;
switch (size) {
case -1:
case 0:
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
- (long) va_arg(argList, int)));
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
+ va_arg(argList, int)));
break;
case 1:
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
va_arg(argList, long)));
break;
+ case 2:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
+ va_arg(argList, Tcl_WideInt)));
+ break;
+ case 3:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj(
+ va_arg(argList, mp_int *)));
+ break;
}
break;
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
+ if (size > 0) {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
- va_arg(argList, double)));
+ (double)va_arg(argList, long double)));
+ } else {
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
+ va_arg(argList, double)));
+ }
seekingConversion = 0;
break;
case '*':
lastNum = (int) va_arg(argList, int);
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
@@ -2749,9 +3174,35 @@ AppendPrintfToObjVA(
gotPrecision = 1;
p++;
break;
- /* TODO: support for wide (and bignum?) arguments */
case 'l':
- size = 1;
+ ++size;
+ p++;
+ break;
+ case 't':
+ case 'z':
+ if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ p++;
+ break;
+ case 'j':
+ case 'q':
+ size = 2;
+ p++;
+ break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ } else if (p[1]=='3' && p[2]=='2') {
+ p += 2;
+ } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ p++;
+ break;
+ case 'L':
+ size = 3;
p++;
break;
case 'h':
@@ -2762,7 +3213,7 @@ AppendPrintfToObjVA(
}
} while (seekingConversion);
}
- TclListObjGetElements(NULL, list, &objc, &objv);
+ TclListObjGetElementsM(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
@@ -2850,16 +3301,929 @@ TclGetStringStorage(
Tcl_Obj *objPtr,
unsigned int *sizePtr)
{
- String *stringPtr;
+ UniCharString *stringPtr;
- if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) {
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, (int *)sizePtr);
}
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringRepeat --
+ *
+ * Performs the [string repeat] function.
+ *
+ * Results:
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
+ *
+ * Side effects:
+ * On error, when interp is not NULL, error information is left in it.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringRepeat(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int count,
+ int flags)
+{
+ Tcl_Obj *objResultPtr;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ int length = 0, unichar = 0, done = 1;
+ int binary = TclIsPureByteArray(objPtr);
+
+ /* assert (count >= 2) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ if (!binary) {
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
+ if (stringPtr->hasUnicode) {
+ unichar = 1;
+ }
+ }
+ }
+
+ if (binary) {
+ /* Result will be pure byte array. Pre-size it */
+ Tcl_GetByteArrayFromObj(objPtr, &length);
+ } else if (unichar) {
+ /* Result will be pure Tcl_UniChar array. Pre-size it. */
+ TclGetUnicodeFromObj_(objPtr, &length);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ Tcl_GetStringFromObj(objPtr, &length);
+ }
+
+ if (length == 0) {
+ /* Any repeats of empty is empty. */
+ return objPtr;
+ }
+
+ if (count > INT_MAX/length) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
+ Tcl_DuplicateObj(objPtr) : objPtr;
+
+ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
+ Tcl_SetByteArrayLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ TclAppendBytesToByteArray(objResultPtr,
+ TclGetByteArrayFromObj(objResultPtr, NULL),
+ (count - done) * length);
+ } else if (unichar) {
+ /*
+ * Efficiently produce a pure Tcl_UniChar array result.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = TclNewUnicodeObj(TclGetUnicodeFromObj_(objPtr, NULL), length);
+ } else {
+ TclInvalidateStringRep(objPtr);
+ objResultPtr = objPtr;
+ }
+
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(count*length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ TclAppendUnicodeToObj(objResultPtr, TclGetUnicodeFromObj_(objResultPtr, NULL),
+ (count - done) * length);
+ } else {
+ /*
+ * Efficiently concatenate string reps.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
+ } else {
+ TclFreeInternalRep(objPtr);
+ objResultPtr = objPtr;
+ }
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %u bytes",
+ count*length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
+ (count - done) * length);
+ }
+ return objResultPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCat --
+ *
+ * Performs the [string cat] function.
+ *
+ * Results:
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
+ *
+ * Side effects:
+ * On error, when interp is not NULL, error information is left in it.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringCat(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const objv[],
+ int flags)
+{
+ Tcl_Obj *objResultPtr, * const *ov;
+ int oc, length = 0, binary = 1;
+ int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
+ int first = objc - 1; /* Index of first value possibly not empty */
+ int last = 0; /* Index of last value possibly not empty */
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+
+ /* assert ( objc >= 0 ) */
+
+ if (objc <= 1) {
+ /* Only one or no objects; return first or empty */
+ return objc ? objv[0] : Tcl_NewObj();
+ }
+
+ /* assert ( objc >= 2 ) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ ov = objv, oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ if (TclIsPureByteArray(objPtr)) {
+ allowUniChar = 0;
+ } else if (objPtr->bytes) {
+ /* Value has a string rep. */
+ if (objPtr->length) {
+ /*
+ * Non-empty string rep. Not a pure bytearray, so we won't
+ * create a pure bytearray.
+ */
+
+ binary = 0;
+ if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
+ forceUniChar = 1;
+ } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclUniCharStringType)) {
+ /* Prevent shimmer of non-string types. */
+ allowUniChar = 0;
+ }
+ }
+ } else {
+ /* assert (objPtr->typePtr != NULL) -- stork! */
+ binary = 0;
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ /* Have a pure Unicode value; ask to preserve it */
+ requestUniChar = 1;
+ } else {
+ /* Have another type; prevent shimmer */
+ allowUniChar = 0;
+ }
+ }
+ } while (--oc && (binary || allowUniChar));
+
+ if (binary) {
+ /*
+ * Result will be pure byte array. Pre-size it
+ */
+
+ int numBytes;
+ ov = objv;
+ oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to count bytes for the empty strings.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
+
+ if (numBytes) {
+ last = objc - oc;
+ if (length == 0) {
+ first = last;
+ } else if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ }
+ } while (--oc);
+ } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ /*
+ * Result will be pure Tcl_UniChar array. Pre-size it.
+ */
+
+ ov = objv;
+ oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int numChars;
+
+ TclGetUnicodeFromObj_(objPtr, &numChars); /* PANIC? */
+ if (numChars) {
+ last = objc - oc;
+ if (length == 0) {
+ first = last;
+ } else if (numChars > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numChars;
+ }
+ }
+ } while (--oc);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ ov = objv; oc = objc;
+ do {
+ Tcl_Obj *pendingPtr = NULL;
+
+ /*
+ * Loop until a possibly non-empty value is reached.
+ * Keep string rep generation pending when possible.
+ */
+
+ do {
+ /* assert ( pendingPtr == NULL ) */
+ /* assert ( length == 0 ) */
+
+ Tcl_Obj *objPtr = *ov++;
+
+ if (objPtr->bytes == NULL) {
+ /* No string rep; Take the chance we can avoid making it */
+ pendingPtr = objPtr;
+ } else {
+ Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
+ }
+ } while (--oc && (length == 0) && (pendingPtr == NULL));
+
+ /*
+ * Either we found a possibly non-empty value, and we remember
+ * this index as the first and last such value so far seen,
+ * or (oc == 0) and all values are known empty,
+ * so first = last = objc - 1 signals the right quick return.
+ */
+
+ first = last = objc - oc - 1;
+
+ if (oc && (length == 0)) {
+ int numBytes;
+
+ /* assert ( pendingPtr != NULL ) */
+
+ /*
+ * There's a pending value followed by more values. Loop over
+ * remaining values generating strings until a non-empty value
+ * is found, or the pending value gets its string generated.
+ */
+
+ do {
+ Tcl_Obj *objPtr = *ov++;
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+ if (numBytes) {
+ last = objc -oc -1;
+ }
+ if (oc || numBytes) {
+ Tcl_GetStringFromObj(pendingPtr, &length);
+ }
+ if (length == 0) {
+ if (numBytes) {
+ first = last;
+ }
+ } else if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ } while (oc && (length == 0));
+
+ while (oc) {
+ int numBytes;
+ Tcl_Obj *objPtr = *ov++;
+
+ /* assert ( length > 0 && pendingPtr == NULL ) */
+
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ if (numBytes) {
+ last = objc - oc;
+ if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ --oc;
+ }
+ }
+
+ if (last <= first /*|| length == 0 */) {
+ /* Only one non-empty value or zero length; return first */
+ /* NOTE: (length == 0) implies (last <= first) */
+ return objv[first];
+ }
+
+ objv += first; objc = (last - first + 1);
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ unsigned char *dst;
+
+ /*
+ * Broken interface! Byte array value routines offer no way to handle
+ * failure to allocate enough space. Following stanza may panic.
+ */
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+ Tcl_GetByteArrayFromObj(objResultPtr, &start);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
+ } else {
+ objResultPtr = Tcl_NewByteArrayObj(NULL, length);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to copy bytes from the empty strings.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ int more;
+ unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
+ memcpy(dst, src, more);
+ dst += more;
+ }
+ }
+ } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ /* Efficiently produce a pure Tcl_UniChar array result */
+ Tcl_UniChar *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ /* Ugly interface! Force resize of the unicode array. */
+ TclGetUnicodeFromObj_(objResultPtr, &start);
+ Tcl_InvalidateStringRep(objResultPtr);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = TclGetUnicodeFromObj_(objResultPtr, NULL) + start;
+ } else {
+ Tcl_UniChar ch = 0;
+
+ /* Ugly interface! No scheme to init array size. */
+ objResultPtr = TclNewUnicodeObj(&ch, 0); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ Tcl_DecrRefCount(objResultPtr);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = TclGetUnicodeFromObj_(objResultPtr, NULL);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int more;
+ Tcl_UniChar *src = TclGetUnicodeFromObj_(objPtr, &more);
+ memcpy(dst, src, more * sizeof(Tcl_UniChar));
+ dst += more;
+ }
+ }
+ } else {
+ /* Efficiently concatenate string reps */
+ char *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ Tcl_GetStringFromObj(objResultPtr, &start);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetString(objResultPtr) + start;
+
+ /* assert ( length > start ) */
+ TclFreeInternalRep(objResultPtr);
+ } else {
+ TclNewObj(objResultPtr); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ Tcl_DecrRefCount(objResultPtr);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetString(objResultPtr);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int more;
+ char *src = Tcl_GetStringFromObj(objPtr, &more);
+
+ memcpy(dst, src, more);
+ dst += more;
+ }
+ }
+ /* Must NUL-terminate! */
+ *dst = '\0';
+ }
+ return objResultPtr;
+
+ overflow:
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCmp --
+ * Compare two Tcl_Obj values as strings.
+ *
+ * Results:
+ * Like memcmp, return -1, 0, or 1.
+ *
+ * Side effects:
+ * String representations may be generated. Internal representation may
+ * be changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringCmp(
+ Tcl_Obj *value1Ptr,
+ Tcl_Obj *value2Ptr,
+ int checkEq, /* comparison is only for equality */
+ int nocase, /* comparison is not case sensitive */
+ int reqlength) /* requested length in characters;
+ * TCL_INDEX_NONE to compare whole strings */
+{
+ const char *s1, *s2;
+ int empty, length, match, s1len, s2len;
+ memCmpFn_t memCmpFn;
+
+ if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
+ /*
+ * Always match at 0 chars of if it is the same obj.
+ */
+ match = 0;
+ } else {
+ if (!nocase && TclIsPureByteArray(value1Ptr)
+ && TclIsPureByteArray(value2Ptr)) {
+ /*
+ * Use binary versions of comparisons since that won't cause undue
+ * type conversions and it is much faster. Only do this if we're
+ * case-sensitive (which is all that really makes sense with byte
+ * arrays anyway, and we have no memcasecmp() for some reason... :^)
+ */
+
+ s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
+ s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+ memCmpFn = memcmp;
+ } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType)
+ && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
+ /*
+ * 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 (nocase) {
+ s1 = (char *) TclGetUnicodeFromObj_(value1Ptr, &s1len);
+ s2 = (char *) TclGetUnicodeFromObj_(value2Ptr, &s2len);
+ memCmpFn = (memCmpFn_t)(void *)TclUniCharNcasecmp;
+ } else {
+ s1len = TclGetCharLength(value1Ptr);
+ s2len = TclGetCharLength(value2Ptr);
+ if ((s1len == value1Ptr->length)
+ && (value1Ptr->bytes != NULL)
+ && (s2len == value2Ptr->length)
+ && (value2Ptr->bytes != NULL)) {
+ /* each byte represents one character so s1l3n, s2l3n, and
+ * reqlength are in both bytes and characters
+ */
+ s1 = value1Ptr->bytes;
+ s2 = value2Ptr->bytes;
+ memCmpFn = memcmp;
+ } else {
+ s1 = (char *) TclGetUnicodeFromObj_(value1Ptr, NULL);
+ s2 = (char *) TclGetUnicodeFromObj_(value2Ptr, NULL);
+ if (
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
+ 1
+#else
+ checkEq
+#endif
+ ) {
+ memCmpFn = memcmp;
+ s1len *= sizeof(Tcl_UniChar);
+ s2len *= sizeof(Tcl_UniChar);
+ if (reqlength > 0) {
+ reqlength *= sizeof(Tcl_UniChar);
+ }
+ } else {
+ memCmpFn = (memCmpFn_t)(void *)TclUniCharNcmp;
+ }
+ }
+ }
+ } else {
+ empty = TclCheckEmptyString(value1Ptr);
+ if (empty > 0) {
+ switch (TclCheckEmptyString(value2Ptr)) {
+ case -1:
+ s1 = 0;
+ s1len = 0;
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ break;
+ case 0:
+ match = -1;
+ goto matchdone;
+ case 1:
+ default: /* avoid warn: `s2` may be used uninitialized */
+ match = 0;
+ goto matchdone;
+ }
+ } else if (TclCheckEmptyString(value2Ptr) > 0) {
+ switch (empty) {
+ case -1:
+ s2 = 0;
+ s2len = 0;
+ s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ break;
+ case 0:
+ match = 1;
+ goto matchdone;
+ case 1:
+ default: /* avoid warn: `s1` may be used uninitialized */
+ match = 0;
+ goto matchdone;
+ }
+ } else {
+ s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ }
+ if (!nocase && checkEq && reqlength < 0) {
+ /*
+ * When we have equal-length we can check only for
+ * (in)equality. We can use memcmp in all (n)eq cases because
+ * we don't need to worry about lexical LE/BE variance.
+ */
+
+ memCmpFn = memcmp;
+ } else {
+ /*
+ * As a catch-all we will work with UTF-8. We cannot use
+ * memcmp() as that is unsafe with any string containing NUL
+ * (\xC0\x80 in Tcl's utf rep). We can use the more efficient
+ * TclpUtfNcmp2 if we are case-sensitive and no specific
+ * length was requested.
+ */
+
+ if ((reqlength < 0) && !nocase) {
+ memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2;
+ } else {
+ s1len = Tcl_NumUtfChars(s1, s1len);
+ s2len = Tcl_NumUtfChars(s2, s2len);
+ memCmpFn = (memCmpFn_t)(void *)
+ (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
+ }
+ }
+ }
+
+ /* At this point s1len, s2len, and reqlength should by now have been
+ * adjusted so that they are all in the units expected by the selected
+ * comparison function.
+ */
+ length = (s1len < s2len) ? s1len : s2len;
+ if (reqlength > 0 && reqlength < length) {
+ length = reqlength;
+ } else if (reqlength < 0) {
+ /*
+ * The requested length is negative, so ignore it by setting it
+ * to length + 1 to correct the match var.
+ */
+
+ reqlength = length + 1;
+ }
+
+ if (checkEq && reqlength < 0 && (s1len != s2len)) {
+ match = 1; /* This will be reversed below. */
+ } else {
+ /*
+ * The comparison function should compare up to the minimum byte
+ * length only.
+ */
+
+ match = memCmpFn(s1, s2, length);
+ }
+ if ((match == 0) && (reqlength > length)) {
+ match = s1len - s2len;
+ }
+ match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
+ }
+ matchdone:
+ return match;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringFirst --
+ *
+ * Implements the [string first] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * first instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringFirst(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ int start)
+{
+ int lh, ln = TclGetCharLength(needle);
+ Tcl_Obj *result;
+ int value = -1;
+ Tcl_UniChar *checkStr, *endStr, *uh, *un;
+
+ if (start < 0) {
+ start = 0;
+ }
+ if (ln == 0) {
+ /* We don't find empty substrings. Bizarre!
+ * Whenever this routine is turned into a proper substring
+ * finder, change to `return start` after limits imposed. */
+ goto firstEnd;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *end, *check, *bh;
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ /* Find bytes in bytes */
+ bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+ if ((lh < ln) || (start > lh - ln)) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto firstEnd;
+ }
+ end = bh + lh;
+
+ check = bh + start;
+ while (check + ln <= end) {
+ /*
+ * Look for the leading byte of the needle in the haystack
+ * starting at check and stopping when there's not enough room
+ * for the needle left.
+ */
+ check = (unsigned char *)memchr(check, bn[0], (end + 1 - ln) - check);
+ if (check == NULL) {
+ /* Leading byte not found -> needle cannot be found. */
+ goto firstEnd;
+ }
+ /* Leading byte found, check rest of needle. */
+ if (0 == memcmp(check+1, bn+1, ln-1)) {
+ /* Checks! Return the successful index. */
+ value = (check - bh);
+ goto firstEnd;
+ }
+ /* Rest of needle match failed; Iterate to continue search. */
+ check++;
+ }
+ goto firstEnd;
+ }
+
+ /*
+ * TODO: It might be nice to support some cases where it is not
+ * necessary to shimmer to &tclStringType to compute the result,
+ * and instead operate just on the objPtr->bytes values directly.
+ * However, we also do not want the answer to change based on the
+ * code pathway, or if it does we want that to be for some values
+ * we explicitly decline to support. Getting there will involve
+ * locking down in practice more firmly just what encodings produce
+ * what supported results for the objPtr->bytes values. For now,
+ * do only the well-defined Tcl_UniChar array search.
+ */
+
+ un = TclGetUnicodeFromObj_(needle, &ln);
+ uh = TclGetUnicodeFromObj_(haystack, &lh);
+ if ((lh < ln) || (start > lh - ln)) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto firstEnd;
+ }
+ endStr = uh + lh;
+
+ for (checkStr = uh + start; checkStr + ln <= endStr; checkStr++) {
+ if ((*checkStr == *un) && (0 ==
+ memcmp(checkStr + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
+ value = (checkStr - uh);
+ goto firstEnd;
+ }
+ }
+ firstEnd:
+ TclNewIndexObj(result, value);
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringLast --
+ *
+ * Implements the [string last] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * last instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringLast(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ int last)
+{
+ int lh, ln = TclGetCharLength(needle);
+ Tcl_Obj *result;
+ int value = -1;
+ Tcl_UniChar *checkStr, *uh, *un;
+
+ if (ln == 0) {
+ /*
+ * We don't find empty substrings. Bizarre!
+ *
+ * TODO: When we one day make this a true substring
+ * finder, change this to "return last", after limitation.
+ */
+ goto lastEnd;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ if (last >= lh) {
+ last = lh - 1;
+ }
+ if (last + 1 < ln) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto lastEnd;
+ }
+ check = bh + last + 1 - ln;
+
+ while (check >= bh) {
+ if ((*check == bn[0])
+ && (0 == memcmp(check+1, bn+1, ln-1))) {
+ value = (check - bh);
+ goto lastEnd;
+ }
+ check--;
+ }
+ goto lastEnd;
+ }
+
+ uh = TclGetUnicodeFromObj_(haystack, &lh);
+ un = TclGetUnicodeFromObj_(needle, &ln);
+
+ if (last >= lh) {
+ last = lh - 1;
+ }
+ if (last + 1 < ln) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto lastEnd;
+ }
+ checkStr = uh + last + 1 - ln;
+ while (checkStr >= uh) {
+ if ((*checkStr == un[0])
+ && (0 == memcmp(checkStr+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ value = (checkStr - uh);
+ goto lastEnd;
+ }
+ checkStr--;
+ }
+ lastEnd:
+ TclNewIndexObj(result, value);
+ return result;
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -2868,9 +4232,9 @@ TclGetStringStorage(
* Implements the [string reverse] operation.
*
* 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.
+ * A Tcl value which is the [string reverse] of the argument supplied.
+ * When sharing rules permit and the caller requests, the returned value
+ * might be the argument with modifications done in place.
*
* Side effects:
* May allocate a new Tcl_Obj.
@@ -2904,11 +4268,13 @@ ReverseBytes(
Tcl_Obj *
TclStringReverse(
- Tcl_Obj *objPtr)
+ Tcl_Obj *objPtr,
+ int flags)
{
- String *stringPtr;
+ UniCharString *stringPtr;
Tcl_UniChar ch = 0;
-#if TCL_UTF_MAX <= 4
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+#if TCL_UTF_MAX < 4
int needFlip = 0;
#endif
@@ -2916,32 +4282,34 @@ TclStringReverse(
int numBytes;
unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
}
- ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes);
+ ReverseBytes(TclGetByteArrayFromObj(objPtr, NULL), from, numBytes);
return objPtr;
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode) {
- Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
+ Tcl_UniChar *from = TclGetUnicodeFromObj_(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
Tcl_UniChar *to;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
/*
* Create a non-empty, pure unicode value, so we can coax
* Tcl_SetObjLength into growing the unicode rep buffer.
*/
- objPtr = Tcl_NewUnicodeObj(&ch, 1);
+ objPtr = TclNewUnicodeObj(&ch, 1);
Tcl_SetObjLength(objPtr, stringPtr->numChars);
- to = Tcl_GetUnicode(objPtr);
+ to = TclGetUnicodeFromObj_(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
while (--src >= from) {
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
ch = *src;
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
@@ -2956,12 +4324,12 @@ TclStringReverse(
* Reversing in place.
*/
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
to = src;
#endif
while (--src > from) {
ch = *src;
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
}
@@ -2970,7 +4338,7 @@ TclStringReverse(
*from++ = ch;
}
}
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
if (needFlip) {
/*
* Flip back surrogate pairs.
@@ -2996,7 +4364,7 @@ TclStringReverse(
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
TclNewObj(objPtr);
Tcl_SetObjLength(objPtr, numBytes);
}
@@ -3043,6 +4411,151 @@ TclStringReverse(
/*
*---------------------------------------------------------------------------
*
+ * TclStringReplace --
+ *
+ * Implements the inner engine of the [string replace] and
+ * [string insert] commands.
+ *
+ * The result is a concatenation of a prefix from objPtr, characters
+ * 0 through first-1, the insertPtr string value, and a suffix from
+ * objPtr, characters from first + count to the end. The effect is as if
+ * the inner substring of characters first through first+count-1 are
+ * removed and replaced with insertPtr. If insertPtr is NULL, it is
+ * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE,
+ * this routine will try to do the work within objPtr, so long as no
+ * sharing forbids it. Without that request, or as needed, a new Tcl
+ * value will be allocated to be the result.
+ *
+ * Results:
+ * A Tcl value that is the result of the substring replacement. May
+ * return NULL in case of an error. When NULL is returned and interp is
+ * non-NULL, error information is left in interp
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringReplace(
+ Tcl_Interp *interp, /* For error reporting, may be NULL */
+ Tcl_Obj *objPtr, /* String to act upon */
+ int first, /* First index to replace */
+ int count, /* How many chars to replace */
+ Tcl_Obj *insertPtr, /* Replacement string, may be NULL */
+ int flags) /* TCL_STRING_IN_PLACE => attempt in-place */
+{
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ Tcl_Obj *result;
+
+ /* Caller is expected to pass sensible arguments */
+ assert ( count >= 0 ) ;
+ assert ( first >= 0 ) ;
+
+ /* Replace nothing with nothing */
+ if ((insertPtr == NULL) && (count == 0)) {
+ if (inPlace) {
+ return objPtr;
+ } else {
+ return Tcl_DuplicateObj(objPtr);
+ }
+ }
+
+ /*
+ * The caller very likely had to call Tcl_GetCharLength() or similar
+ * to be able to process index values. This means it is likely that
+ * objPtr is either a proper "bytearray" or a "string" or else it has
+ * a known and short string rep.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ int numBytes;
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
+
+ if (insertPtr == NULL) {
+ /* Replace something with nothing. */
+
+ assert ( first <= numBytes ) ;
+ assert ( count <= numBytes ) ;
+ assert ( first + count <= numBytes ) ;
+
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Replace everything */
+ if ((first == 0) && (count == numBytes)) {
+ return insertPtr;
+ }
+
+ if (TclIsPureByteArray(insertPtr)) {
+ int newBytes;
+ unsigned char *iBytes
+ = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);
+
+ if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
+ /*
+ * Removal count and replacement count are equal.
+ * Other conditions permit. Do in-place splice.
+ */
+
+ memcpy(bytes + first, iBytes, count);
+ Tcl_InvalidateStringRep(objPtr);
+ return objPtr;
+ }
+
+ if (newBytes > INT_MAX - (numBytes - count)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded",
+ INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
+ /* PANIC? */
+ Tcl_SetByteArrayLength(result, 0);
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, iBytes, newBytes);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Flow through to try other approaches below */
+ }
+
+ /*
+ * TODO: Figure out how not to generate a Tcl_UniChar array rep
+ * when it can be determined objPtr->bytes points to a string of
+ * all single-byte characters so we can index it directly.
+ */
+
+ /* The traditional implementation... */
+ {
+ int numChars;
+ Tcl_UniChar *ustring = TclGetUnicodeFromObj_(objPtr, &numChars);
+
+ /* TODO: Is there an in-place option worth pursuing here? */
+
+ result = TclNewUnicodeObj(ustring, first);
+ if (insertPtr) {
+ Tcl_AppendObjToObj(result, insertPtr);
+ }
+ if (first + count < numChars) {
+ TclAppendUnicodeToObj(result, ustring + first + count,
+ numChars - first - count);
+ }
+
+ return result;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
@@ -3062,7 +4575,7 @@ FillUnicodeRep(
Tcl_Obj *objPtr) /* The object in which to fill the unicode
* rep. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length,
stringPtr->numChars);
@@ -3075,7 +4588,7 @@ ExtendUnicodeRepWithString(
int numBytes,
int numAppendChars)
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
int needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
@@ -3083,14 +4596,14 @@ ExtendUnicodeRepWithString(
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == -1) {
- TclNumUtfChars(numAppendChars, bytes, numBytes);
+ TclNumUtfCharsM(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
- stringCheckLimits(needed);
+ uniCharStringCheckLimits(needed);
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
stringPtr->hasUnicode = 1;
@@ -3099,9 +4612,22 @@ ExtendUnicodeRepWithString(
} else {
numAppendChars = 0;
}
- for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
+ dst = stringPtr->unicode + numOrigChars;
+ if (numAppendChars-- > 0) {
bytes += TclUtfToUniChar(bytes, &unichar);
- *dst = unichar;
+#if TCL_UTF_MAX > 3
+ /* join upper/lower surrogate */
+ if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) {
+ stringPtr->numChars--;
+ unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000;
+ dst--;
+ }
+#endif
+ *dst++ = unichar;
+ while (numAppendChars-- > 0) {
+ bytes += TclUtfToUniChar(bytes, &unichar);
+ *dst++ = unichar;
+ }
}
*dst = 0;
}
@@ -3131,10 +4657,9 @@ DupStringInternalRep(
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- String *srcStringPtr = GET_STRING(srcPtr);
- String *copyStringPtr = NULL;
+ UniCharString *srcStringPtr = GET_UNICHAR_STRING(srcPtr);
+ UniCharString *copyStringPtr = NULL;
-#if COMPAT==0
if (srcStringPtr->numChars == -1) {
/*
* The String struct in the source value holds zero useful data. Don't
@@ -3153,17 +4678,17 @@ DupStringInternalRep(
} else {
copyMaxChars = srcStringPtr->maxChars;
}
- copyStringPtr = stringAttemptAlloc(copyMaxChars);
+ copyStringPtr = uniCharStringAttemptAlloc(copyMaxChars);
if (copyStringPtr == NULL) {
copyMaxChars = srcStringPtr->numChars;
- copyStringPtr = stringAlloc(copyMaxChars);
+ copyStringPtr = uniCharStringAlloc(copyMaxChars);
}
copyStringPtr->maxChars = copyMaxChars;
memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
srcStringPtr->numChars * sizeof(Tcl_UniChar));
copyStringPtr->unicode[srcStringPtr->numChars] = 0;
} else {
- copyStringPtr = stringAlloc(0);
+ copyStringPtr = uniCharStringAlloc(0);
copyStringPtr->maxChars = 0;
copyStringPtr->unicode[0] = 0;
}
@@ -3177,44 +4702,9 @@ DupStringInternalRep(
*/
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;
+ SET_UNICHAR_STRING(copyPtr, copyStringPtr);
+ copyPtr->typePtr = &tclUniCharStringType;
}
/*
@@ -3236,18 +4726,18 @@ DupStringInternalRep(
static int
SetStringFromAny(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert. */
{
- if (objPtr->typePtr != &tclStringType) {
- String *stringPtr = stringAlloc(0);
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ UniCharString *stringPtr = uniCharStringAlloc(0);
/*
* Convert whatever we have into an untyped value. Just A String.
*/
(void) TclGetString(objPtr);
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
/*
* Create a basic String internalrep that just points to the UTF-8 string
@@ -3258,8 +4748,8 @@ SetStringFromAny(
stringPtr->allocated = objPtr->length;
stringPtr->maxChars = 0;
stringPtr->hasUnicode = 0;
- SET_STRING(objPtr, stringPtr);
- objPtr->typePtr = &tclStringType;
+ SET_UNICHAR_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclUniCharStringType;
}
return TCL_OK;
}
@@ -3286,7 +4776,7 @@ static void
UpdateStringOfString(
Tcl_Obj *objPtr) /* Object with string rep to update. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* This routine is only called when we need to generate the
@@ -3299,7 +4789,7 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, NULL, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
@@ -3317,8 +4807,8 @@ ExtendStringRepWithUnicode(
*/
int i, origLength, size = 0;
- char *dst, buf[4] = "";
- String *stringPtr = GET_STRING(objPtr);
+ char *dst;
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
if (numChars < 0) {
numChars = UnicodeLength(unicode);
@@ -3343,7 +4833,7 @@ ExtendStringRepWithUnicode(
}
for (i = 0; i < numChars && size >= 0; i++) {
- size += (unsigned int)Tcl_UniCharToUtf((int) unicode[i], buf);
+ size += (unsigned int)TclUtfCount(unicode[i]);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
@@ -3372,7 +4862,7 @@ ExtendStringRepWithUnicode(
*
* FreeStringInternalRep --
*
- * Deallocate the storage associated with a String data object's internal
+ * Deallocate the storage associated with a (UniChar)String data object's internal
* representation.
*
* Results:
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index dc33f4b..bce9092 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -31,6 +31,10 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+
+#ifndef _TCLSTRINGREP
+#define _TCLSTRINGREP
+
/*
* The following structure is the internal rep for a String object. It keeps
@@ -39,35 +43,30 @@
* Unicode reps of the String object with fewer mallocs. To optimize string
* length and indexing operations, this structure also stores the number of
* characters (same of UTF and Unicode!) once that value has been computed.
- *
- * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
- * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
- * can be officially modified by altering the definition of Tcl_UniChar in
- * tcl.h, but do not do that unless you are sure what you're doing!
*/
-typedef struct String {
- int numChars; /* The number of chars in the string. -1 means
- * this value has not been calculated. >= 0
- * means that there is a valid Unicode rep, or
- * that the number of UTF bytes == the number
- * of chars. */
- int allocated; /* The amount of space actually allocated for
+typedef struct {
+ Tcl_Size numChars; /* The number of chars in the string.
+ * TCL_INDEX_NONE means this value has not been
+ * calculated. Any other means that there is a valid
+ * Unicode rep, or that the number of UTF bytes ==
+ * the number of chars. */
+ Tcl_Size allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
- int maxChars; /* Max number of chars that can fit in the
+ Tcl_Size 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[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
+ unsigned short unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
* of this field depends on the 'maxChars'
* field above. */
} String;
#define STRING_MAXCHARS \
- (int)(((size_t)UINT_MAX - TclOffset(String, unicode))/sizeof(Tcl_UniChar) - 1)
+ (int)(((size_t)UINT_MAX - offsetof(String, unicode))/sizeof(unsigned short) - 1)
#define STRING_SIZE(numChars) \
- (TclOffset(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
+ (offsetof(String, unicode) + sizeof(unsigned short) + ((numChars) * sizeof(unsigned short)))
#define stringCheckLimits(numChars) \
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
@@ -76,18 +75,20 @@ typedef struct String {
} \
} while (0)
#define stringAttemptAlloc(numChars) \
- (String *) attemptckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
- (String *) ckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
+ ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
+#endif /* _TCLSTRINGREP */
/*
* Local Variables:
* mode: c
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ee0412a..ddc0bc9 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -3,7 +3,7 @@
*
* This file contains the initializers for the Tcl stub vectors.
*
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -11,6 +11,7 @@
#include "tclInt.h"
#include "tommath_private.h"
+#include "tclTomMath.h"
#ifdef __CYGWIN__
# include <wchar.h>
@@ -35,34 +36,241 @@
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
+#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
+#undef Tcl_GetUnicode
+#undef Tcl_GetUnicodeFromObj
+#undef Tcl_AppendUnicodeToObj
+#undef Tcl_NewUnicodeObj
+#undef Tcl_SetUnicodeObj
+#undef Tcl_UniCharNcasecmp
+#undef Tcl_UniCharCaseMatch
+#undef Tcl_UniCharLen
+#undef Tcl_UniCharNcmp
+#undef Tcl_GetRange
+#undef Tcl_GetUniChar
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
+#undef Tcl_SetExitProc
+#undef Tcl_SetPanicProc
#undef TclpGetPid
#undef TclSockMinimumBuffers
-#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
+#undef Tcl_SetLongObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
-#undef TclBN_mp_tc_and
-#undef TclBN_mp_tc_or
-#undef TclBN_mp_tc_xor
+#undef TclWinNToHS
+#undef TclStaticLibrary
+#undef Tcl_BackgroundError
+#undef TclGuessPackageName
+#undef TclGetLoadedPackages
+#define TclStaticLibrary Tcl_StaticLibrary
+#undef Tcl_UniCharToUtfDString
+#undef Tcl_UtfToUniCharDString
+#undef Tcl_UtfToUniChar
+#undef Tcl_MacOSXOpenBundleResources
+#undef TclWinConvertWSAError
+#undef TclWinConvertError
+#undef Tcl_NumUtfChars
+#undef Tcl_GetCharLength
+#undef Tcl_UtfAtIndex
+#undef Tcl_GetRange
+#undef Tcl_GetUniChar
#undef TclObjInterpProc
+
+#if defined(_WIN32) || defined(__CYGWIN__)
+#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#endif
+
+
+#if TCL_UTF_MAX > 3 && defined(TCL_NO_DEPRECATED)
+static void uniCodePanic(void) {
+ Tcl_Panic("Tcl is compiled without the the UTF16 compatibility layer (-DTCL_NO_DEPRECATED)");
+}
+# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic
+# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
+# define TclGetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic
+# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_UtfAtIndex (const char *(*)(const char *, int))(void *)uniCodePanic
+# define Tcl_GetCharLength (int(*)(Tcl_Obj *))(void *)uniCodePanic
+# define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic
+# define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic
+# define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic
+# define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic
+# define Tcl_NumUtfChars (int(*)(const char *, int))(void *)uniCodePanic
+#endif
+
+#define TclUtfCharComplete UtfCharComplete
+#define TclUtfNext UtfNext
+#define TclUtfPrev UtfPrev
+
+static int TclUtfCharComplete(const char *src, int length) {
+ if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) {
+ return length < 3;
+ }
+ return Tcl_UtfCharComplete(src, length);
+}
+
+static const char *TclUtfNext(const char *src) {
+ if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) {
+ return src + 1;
+ }
+ return Tcl_UtfNext(src);
+}
+
+static const char *TclUtfPrev(const char *src, const char *start) {
+ if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80)
+ && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) {
+ return src - 3;
+ }
+ return Tcl_UtfPrev(src, start);
+}
+
+int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ size_t *objcPtr, Tcl_Obj ***objvPtr) {
+ int n, result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
+ if ((result == TCL_OK) && objcPtr) {
+ *objcPtr = n;
+ }
+ return result;
+}
+int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ size_t *lengthPtr) {
+ int n;
+ int result = Tcl_ListObjLength(interp, listPtr, &n);
+ if ((result == TCL_OK) && lengthPtr) {
+ *lengthPtr = n;
+ }
+ return result;
+}
+int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+ size_t *sizePtr) {
+ int n, result = Tcl_DictObjSize(interp, dictPtr, &n);
+ if ((result == TCL_OK) && sizePtr) {
+ *sizePtr = n;
+ }
+ return result;
+}
+int TclSplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr,
+ const char ***argvPtr) {
+ int n;
+ int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
+ if ((result == TCL_OK) && argcPtr) {
+ *argcPtr = n;
+ }
+ return result;
+}
+void TclSplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) {
+ int n;
+ Tcl_SplitPath(path, &n, argvPtr);
+ if (argcPtr) {
+ *argcPtr = n;
+ }
+}
+Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) {
+ int n;
+ Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
+ if (result && lenPtr) {
+ *lenPtr = n;
+ }
+ return result;
+}
+int TclParseArgsObjv(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv,
+ Tcl_Obj ***remObjv) {
+ int n, result;
+ if (*objcPtr > INT_MAX) {
+ if (interp) {
+ Tcl_AppendResult(interp, "Tcl_ParseArgsObjv cannot handle *objcPtr > INT_MAX", NULL);
+ }
+ return TCL_ERROR;
+ }
+ n = (int)*objcPtr;
+ result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
+ *objcPtr = n;
+ return result;
+}
+
+#define TclBN_mp_add mp_add
+#define TclBN_mp_and mp_and
+#define TclBN_mp_clamp mp_clamp
+#define TclBN_mp_clear mp_clear
+#define TclBN_mp_clear_multi mp_clear_multi
+#define TclBN_mp_cmp mp_cmp
+#define TclBN_mp_cmp_mag mp_cmp_mag
+#define TclBN_mp_cnt_lsb mp_cnt_lsb
+#define TclBN_mp_copy mp_copy
+#define TclBN_mp_count_bits mp_count_bits
+#define TclBN_mp_div mp_div
+#define TclBN_mp_div_2 mp_div_2
+#define TclBN_mp_div_2d mp_div_2d
+#define TclBN_mp_exch mp_exch
+#define TclBN_mp_get_mag_u64 mp_get_mag_u64
+#define TclBN_mp_grow mp_grow
+#define TclBN_mp_init mp_init
+#define TclBN_mp_init_copy mp_init_copy
+#define TclBN_mp_init_multi mp_init_multi
+#define TclBN_mp_init_size mp_init_size
+#define TclBN_mp_init_i64 mp_init_i64
+#define TclBN_mp_init_u64 mp_init_u64
+#define TclBN_mp_lshd mp_lshd
+#define TclBN_mp_mod mp_mod
+#define TclBN_mp_mod_2d mp_mod_2d
+#define TclBN_mp_mul mp_mul
+#define TclBN_mp_mul_2 mp_mul_2
+#define TclBN_mp_mul_2d mp_mul_2d
+#define TclBN_mp_neg mp_neg
+#define TclBN_mp_or mp_or
+#define TclBN_mp_pack mp_pack
+#define TclBN_mp_pack_count mp_pack_count
+#define TclBN_mp_radix_size mp_radix_size
+#define TclBN_mp_reverse mp_reverse
+#define TclBN_mp_read_radix mp_read_radix
+#define TclBN_mp_rshd mp_rshd
+#define TclBN_mp_set_i64 mp_set_i64
+#define TclBN_mp_set_u64 mp_set_u64
+#define TclBN_mp_shrink mp_shrink
+#define TclBN_mp_sqr mp_sqr
+#define TclBN_mp_sqrt mp_sqrt
+#define TclBN_mp_sub mp_sub
+#define TclBN_mp_signed_rsh mp_signed_rsh
#define TclBN_mp_tc_and TclBN_mp_and
+#define TclBN_mp_tc_div_2d mp_signed_rsh
#define TclBN_mp_tc_or TclBN_mp_or
#define TclBN_mp_tc_xor TclBN_mp_xor
-#define TclStaticPackage Tcl_StaticPackage
+#define TclBN_mp_to_radix mp_to_radix
+#define TclBN_mp_to_ubin mp_to_ubin
+#define TclBN_mp_ubin_size mp_ubin_size
+#define TclBN_mp_unpack mp_unpack
+#define TclBN_mp_xor mp_xor
+#define TclBN_mp_zero mp_zero
+#define TclBN_s_mp_add s_mp_add
+#define TclBN_s_mp_balance_mul s_mp_balance_mul
+#define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul
+#define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr
+#define TclBN_s_mp_mul_digs s_mp_mul_digs
+#define TclBN_s_mp_mul_digs_fast s_mp_mul_digs_fast
+#define TclBN_s_mp_reverse s_mp_reverse
+#define TclBN_s_mp_sqr s_mp_sqr
+#define TclBN_s_mp_sqr_fast s_mp_sqr_fast
+#define TclBN_s_mp_sub s_mp_sub
+#define TclBN_mp_toom_mul s_mp_toom_mul
+#define TclBN_mp_toom_sqr s_mp_toom_sqr
#define TclUnusedStubEntry 0
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
-#ifdef _WIN64
+#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
@@ -72,33 +280,41 @@ static int TclSockMinimumBuffersOld(int sock, int size)
}
#endif
-MP_SET_UNSIGNED(mp_set_ull, Tcl_WideUInt)
-MP_GET_MAG(mp_get_mag_ull, Tcl_WideUInt)
-MP_SET_SIGNED(mp_set_ll, mp_set_ull, Tcl_WideInt, Tcl_WideUInt)
-
-
mp_err TclBN_mp_set_int(mp_int *a, unsigned long i)
{
- mp_set_ull(a, i);
- return MP_OKAY;
+ TclBN_mp_set_u64(a, i);
+ return MP_OKAY;
}
-mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i)
+static mp_err TclBN_mp_set_long(mp_int *a, unsigned long i)
{
- mp_err result = mp_init(a);
- if (result == MP_OKAY) {
- mp_set_ull(a, i);
- }
- return result;
+ TclBN_mp_set_u64(a, i);
+ return MP_OKAY;
}
-int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
-{
+#define TclBN_mp_set_ul (void (*)(mp_int *a, unsigned long i))(void *)TclBN_mp_set_long
+
+mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) {
return mp_expt_u32(a, b, c);
}
-
-#define TclBN_mp_div_ld TclBNMpDivLd
-static mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *c, Tcl_WideUInt *d) {
+mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_add_d(a, b, c);
+}
+mp_err TclBN_mp_cmp_d(const mp_int *a, unsigned int b) {
+ return mp_cmp_d(a, b);
+}
+mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_sub_d(a, b, c);
+}
+mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *c, unsigned int *d) {
+ mp_digit d2;
+ mp_err result = mp_div_d(a, b, c, (d ? &d2 : NULL));
+ if (d) {
+ *d = d2;
+ }
+ return result;
+}
+mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) {
mp_err result;
mp_digit d2;
@@ -111,6 +327,140 @@ static mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *c, Tcl_Wi
}
return result;
}
+mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
+ return mp_init_set(a, b);
+}
+mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_mul_d(a, b, c);
+}
+
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+# define TclBN_mp_expt_d_ex 0
+# define TclBN_mp_to_unsigned_bin 0
+# define TclBN_mp_to_unsigned_bin_n 0
+# define TclBN_mp_toradix_n 0
+# undef TclBN_mp_sqr
+# define TclBN_mp_sqr 0
+# undef TclBN_mp_div_3
+# define TclBN_mp_div_3 0
+# define TclBN_mp_init_l 0
+# define TclBN_mp_init_ul 0
+# define TclBN_mp_set 0
+# define TclSetStartupScriptPath 0
+# define TclGetStartupScriptPath 0
+# define TclSetStartupScriptFileName 0
+# define TclGetStartupScriptFileName 0
+# define TclPrecTraceProc 0
+# define TclpInetNtoa 0
+# define TclWinGetServByName 0
+# define TclWinGetSockOpt 0
+# define TclWinSetSockOpt 0
+# define TclWinNToHS 0
+# define TclWinGetPlatformId 0
+# define TclWinResetInterfaces 0
+# define TclWinSetInterfaces 0
+# define TclWinGetPlatformId 0
+# define Tcl_Backslash 0
+# define Tcl_GetDefaultEncodingDir 0
+# define Tcl_SetDefaultEncodingDir 0
+# define Tcl_EvalTokens 0
+# define Tcl_CreateMathFunc 0
+# define Tcl_GetMathFuncInfo 0
+# define Tcl_ListMathFuncs 0
+# define Tcl_SetIntObj 0
+# define Tcl_SetLongObj 0
+# define Tcl_NewIntObj 0
+# define Tcl_NewLongObj 0
+# define Tcl_DbNewLongObj 0
+# define Tcl_BackgroundError 0
+# define Tcl_FreeResult 0
+# define Tcl_ChannelSeekProc 0
+# define Tcl_ChannelCloseProc 0
+# define Tcl_Close 0
+# define Tcl_MacOSXOpenBundleResources 0
+# define TclGuessPackageName 0
+# define TclGetLoadedPackages 0
+# undef TclSetPreInitScript
+# define TclSetPreInitScript 0
+# define TclInitCompiledLocals 0
+#else
+
+#define TclGuessPackageName guessPackageName
+static int TclGuessPackageName(
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(Tcl_DString *)) {
+ return 0;
+}
+#define TclGetLoadedPackages getLoadedPackages
+static int TclGetLoadedPackages(
+ Tcl_Interp *interp, /* Interpreter in which to return information
+ * or error message. */
+ const char *targetName) /* Name of target interpreter or NULL. If
+ * NULL, return info about all interps;
+ * otherwise, just return info about this
+ * interpreter. */
+{
+ return TclGetLoadedLibraries(interp, targetName, NULL);
+}
+
+mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
+ mp_digit d2;
+ mp_err result = mp_div_d(a, 3, c, &d2);
+ if (d) {
+ *d = d2;
+ }
+ return result;
+}
+
+int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c,
+ TCL_UNUSED(int) /*fast*/)
+{
+ return TclBN_mp_expt_u32(a, b, c);
+}
+
+mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
+{
+ return TclBN_mp_to_ubin(a, b, INT_MAX, NULL);
+}
+
+mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
+{
+ size_t n = TclBN_mp_ubin_size(a);
+ if (*outlen < (unsigned long)n) {
+ return MP_VAL;
+ }
+ *outlen = (unsigned long)n;
+ return TclBN_mp_to_ubin(a, b, n, NULL);
+}
+
+void TclBN_reverse(unsigned char *s, int len)
+{
+ if (len > 0) {
+ TclBN_s_mp_reverse(s, (size_t)len);
+ }
+}
+
+mp_err TclBN_mp_init_ul(mp_int *a, unsigned long b)
+{
+ return TclBN_mp_init_u64(a,b);
+}
+
+mp_err TclBN_mp_init_l(mp_int *a, long b)
+{
+ return TclBN_mp_init_i64(a,b);
+}
+
+void TclBN_mp_set(mp_int *a, unsigned int b) {
+ TclBN_mp_set_u64(a, b);
+}
+
+mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
+{
+ if (maxlen < 0) {
+ return MP_VAL;
+ }
+ return TclBN_mp_to_radix(a, str, maxlen, NULL, radix);
+}
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -137,18 +487,36 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
+#undef TclWinGetPlatformId
+#undef TclWinResetInterfaces
+#undef TclWinSetInterfaces
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
+#define TclWinGetPlatformId winGetPlatformId
+static int
+TclWinGetPlatformId(void)
+{
+ return 2; /* VER_PLATFORM_WIN32_NT */;
+}
+#define TclWinResetInterfaces doNothing
+#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
+#endif /* TCL_NO_DEPRECATED */
#define TclpCreateTempFile_ TclpCreateTempFile
#define TclUnixWaitForFile_ TclUnixWaitForFile
-#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
+#ifdef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
+#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode
+#else
#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess
#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty
#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile
@@ -164,20 +532,17 @@ static unsigned short TclWinNToHS(unsigned short ns) {
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty isatty
-# define TclWinSetInterfaces (void (*) (int))(void *)doNothing
-# define TclWinAddProcess (void (*) (void *, unsigned int))(void *)doNothing
-# define TclWinFlushDirtyChannels doNothing
-# define TclWinResetInterfaces doNothing
-
-#define TclWinGetPlatformId winGetPlatformId
-static int
-TclWinGetPlatformId()
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+static void
+doNothing(void)
{
- /* Don't bother to determine the real platform on cygwin,
- * because VER_PLATFORM_WIN32_NT is the only supported platform */
- return 2; /* VER_PLATFORM_WIN32_NT */;
+ /* dummy implementation, no need to do anything */
}
+#endif
+# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
+# define TclWinFlushDirtyChannels doNothing
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TclWinSetSockOpt winSetSockOpt
static int
TclWinSetSockOpt(SOCKET s, int level, int optname,
@@ -200,6 +565,7 @@ TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
#define TclWinNoBackslash winNoBackslash
static char *
@@ -219,7 +585,7 @@ void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- (const char *)&TclWinNoBackslash, &hInstance);
+ (const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
@@ -229,134 +595,28 @@ TclpGetPid(Tcl_Pid pid)
return (int)(size_t)pid;
}
-static void
-doNothing(void)
-{
- /* dummy implementation, no need to do anything */
-}
-
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef Tcl_WinUtfToTChar
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 4
- Tcl_UniChar ch = 0;
- wchar_t *w, *wString;
- const char *p, *end;
- int oldLength;
-#endif
-
Tcl_DStringInit(dsPtr);
- if (!string) {
- return NULL;
- }
-#if TCL_UTF_MAX > 4
-
- if (len < 0) {
- len = strlen(string);
- }
-
- /*
- * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
- * bytes.
- */
-
- oldLength = Tcl_DStringLength(dsPtr);
-
- Tcl_DStringSetLength(dsPtr,
- oldLength + (int) ((len + 1) * sizeof(wchar_t)));
- wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength);
-
- w = wString;
- p = string;
- end = string + len - 4;
- while (p < end) {
- p += TclUtfToUniChar(p, &ch);
- if (ch > 0xFFFF) {
- *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
- } else {
- *w++ = ch;
- }
- }
- end += 4;
- while (p < end) {
- if (Tcl_UtfCharComplete(p, end-p)) {
- p += TclUtfToUniChar(p, &ch);
- } else {
- ch = UCHAR(*p++);
- }
- if (ch > 0xFFFF) {
- *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
- } else {
- *w++ = ch;
- }
- }
- *w = '\0';
- Tcl_DStringSetLength(dsPtr,
- oldLength + ((char *) w - (char *) wString));
-
- return (char *)wString;
-#else
- return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr);
-#endif
+ return (char *)Tcl_UtfToChar16DString(string, len, dsPtr);
}
-
+#undef Tcl_WinTCharToUtf
char *
Tcl_WinTCharToUtf(
const char *string,
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 4
- const wchar_t *w, *wEnd;
- char *p, *result;
- int oldLength, blen = 1;
-#endif
-
Tcl_DStringInit(dsPtr);
- if (!string) {
- return NULL;
- }
- if (len < 0) {
- len = wcslen((wchar_t *)string);
- } else {
- len /= 2;
- }
-#if TCL_UTF_MAX > 4
- oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4);
- result = Tcl_DStringValue(dsPtr) + oldLength;
-
- p = result;
- wEnd = (wchar_t *)string + len;
- for (w = (wchar_t *)string; w < wEnd; ) {
- if (!blen && ((*w & 0xFC00) != 0xDC00)) {
- /* Special case for handling high surrogates. */
- p += Tcl_UniCharToUtf(-1, p);
- }
- blen = Tcl_UniCharToUtf(*w, p);
- p += blen;
- if ((*w >= 0xD800) && (blen < 3)) {
- /* Indication that high surrogate is handled */
- blen = 0;
- }
- w++;
- }
- if (!blen) {
- /* Special case for handling high surrogates. */
- p += Tcl_UniCharToUtf(-1, p);
- }
- Tcl_DStringSetLength(dsPtr, oldLength + (p - result));
-
- return result;
-#else
- return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
-#endif
+ return Tcl_Char16ToUtfDString((const unsigned short *)string, len >> 1, dsPtr);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
@@ -364,33 +624,11 @@ Tcl_WinTCharToUtf(
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
-#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))(void *)dbNewLongObj)
-static Tcl_Obj *dbNewLongObj(
- int intValue,
- const char *file,
- int line
-) {
-#ifdef TCL_MEM_DEBUG
- Tcl_Obj *objPtr;
-
- TclDbNewObj(objPtr, file, line);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.longValue = (long) intValue;
- objPtr->typePtr = &tclIntType;
- return objPtr;
-#else
- return Tcl_NewIntObj(intValue);
-#endif
-}
-#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj
-#define Tcl_NewLongObj (Tcl_Obj*(*)(long))(void *)Tcl_NewIntObj
-#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))(void *)Tcl_SetIntObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
- if ((longValue >= -(long)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -406,7 +644,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
- if ((longValue >= -(long)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -418,10 +656,16 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
+#if TCL_UTF_MAX < 4 && !defined(TCL_NO_DEPRECATED)
static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp
+static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
+ return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
+}
+#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp
+#endif
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
@@ -430,51 +674,176 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp
-static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
- return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
-}
-#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp
-static int formatInt(char *buffer, int n){
- return TclFormatInt(buffer, (long)n);
-}
-#define TclFormatInt (int(*)(char *, long))(void *)formatInt
-#endif
+#endif /* TCL_WIDE_INT_IS_LONG */
-#else /* UNIX and MAC */
+#endif /* __CYGWIN__ */
+
+#if defined(TCL_NO_DEPRECATED)
+# define Tcl_SeekOld 0
+# define Tcl_TellOld 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_PkgPresent
+# define Tcl_PkgPresent 0
+# undef Tcl_PkgProvide
+# define Tcl_PkgProvide 0
+# undef Tcl_PkgRequire
+# define Tcl_PkgRequire 0
+# undef Tcl_GetIndexFromObj
+# define Tcl_GetIndexFromObj 0
+# define Tcl_NewBooleanObj 0
+# undef Tcl_DbNewBooleanObj
+# define Tcl_DbNewBooleanObj 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_SetVar
+# define Tcl_SetVar 0
+# undef Tcl_UnsetVar
+# define Tcl_UnsetVar 0
+# undef Tcl_GetVar
+# define Tcl_GetVar 0
+# undef Tcl_TraceVar
+# define Tcl_TraceVar 0
+# undef Tcl_UntraceVar
+# define Tcl_UntraceVar 0
+# undef Tcl_VarTraceInfo
+# define Tcl_VarTraceInfo 0
+# undef Tcl_UpVar
+# define Tcl_UpVar 0
+# undef Tcl_AddErrorInfo
+# define Tcl_AddErrorInfo 0
+# undef Tcl_AddObjErrorInfo
+# define Tcl_AddObjErrorInfo 0
+# undef Tcl_Eval
+# define Tcl_Eval 0
+# undef Tcl_GlobalEval
+# define Tcl_GlobalEval 0
+# undef Tcl_SaveResult
+# define Tcl_SaveResult 0
+# undef Tcl_RestoreResult
+# define Tcl_RestoreResult 0
+# undef Tcl_DiscardResult
+# define Tcl_DiscardResult 0
+# undef Tcl_SetResult
+# define Tcl_SetResult 0
+# undef Tcl_EvalObj
+# define Tcl_EvalObj 0
+# undef Tcl_GlobalEvalObj
+# define Tcl_GlobalEvalObj 0
+# define TclBackgroundException 0
+# undef TclpReaddir
+# define TclpReaddir 0
+# define TclSetStartupScript 0
+# define TclGetStartupScript 0
+# define TclGetIntForIndex 0
+# define TclCreateNamespace 0
+# define TclDeleteNamespace 0
+# define TclAppendExportList 0
+# define TclExport 0
+# define TclImport 0
+# define TclForgetImport 0
+# define TclGetCurrentNamespace_ 0
+# define TclGetGlobalNamespace_ 0
+# define TclFindNamespace 0
+# define TclFindCommand 0
+# define TclGetCommandFromObj 0
+# define TclGetCommandFullName 0
+# define TclCopyChannelOld 0
+# define Tcl_AppendResultVA 0
+# define Tcl_AppendStringsToObjVA 0
+# define Tcl_SetErrorCodeVA 0
+# define Tcl_PanicVA 0
+# define Tcl_VarEvalVA 0
+# undef TclpGetDate
+# define TclpGetDate 0
+# undef TclpLocaltime
+# define TclpLocaltime 0
+# undef TclpGmtime
+# define TclpGmtime 0
+# define TclpLocaltime_unix 0
+# define TclpGmtime_unix 0
+# define Tcl_SetExitProc 0
+# define Tcl_SetPanicProc 0
+# define Tcl_FindExecutable 0
+#if TCL_UTF_MAX < 4
+# define Tcl_GetUnicode 0
+# define Tcl_AppendUnicodeToObj 0
+# define Tcl_UniCharCaseMatch 0
+# define Tcl_UniCharNcasecmp 0
+# define Tcl_UniCharNcmp 0
+#endif
+# undef Tcl_StringMatch
+# define Tcl_StringMatch 0
+# define TclBN_reverse 0
+# undef TclBN_s_mp_mul_digs_fast
+# define TclBN_s_mp_mul_digs_fast 0
+# undef TclBN_s_mp_sqr_fast
+# define TclBN_s_mp_sqr_fast 0
+# undef TclBN_mp_karatsuba_mul
+# define TclBN_mp_karatsuba_mul 0
+# undef TclBN_mp_karatsuba_sqr
+# define TclBN_mp_karatsuba_sqr 0
+# undef TclBN_mp_toom_mul
+# define TclBN_mp_toom_mul 0
+# undef TclBN_mp_toom_sqr
+# define TclBN_mp_toom_sqr 0
+# undef TclBN_s_mp_add
+# define TclBN_s_mp_add 0
+# undef TclBN_s_mp_mul_digs
+# define TclBN_s_mp_mul_digs 0
+# undef TclBN_s_mp_sqr
+# define TclBN_s_mp_sqr 0
+# undef TclBN_s_mp_sub
+# define TclBN_s_mp_sub 0
+# define Tcl_MakeSafe 0
+# define TclpHasSockets 0
+#else /* TCL_NO_DEPRECATED */
+# define Tcl_SeekOld seekOld
+# define Tcl_TellOld tellOld
+# define TclBackgroundException Tcl_BackgroundException
+# define TclSetStartupScript Tcl_SetStartupScript
+# define TclGetStartupScript Tcl_GetStartupScript
+# define TclGetIntForIndex Tcl_GetIntForIndex
+# define TclCreateNamespace Tcl_CreateNamespace
+# define TclDeleteNamespace Tcl_DeleteNamespace
+# define TclAppendExportList Tcl_AppendExportList
+# define TclExport Tcl_Export
+# define TclImport Tcl_Import
+# define TclForgetImport Tcl_ForgetImport
+# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace
+# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace
+# define TclFindNamespace Tcl_FindNamespace
+# define TclFindCommand Tcl_FindCommand
+# define TclGetCommandFromObj Tcl_GetCommandFromObj
+# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
-#endif
+# define Tcl_MakeSafe TclMakeSafe
-mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
-{
- return mp_to_ubin(a, b, INT_MAX, NULL);
-}
+int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;}
-mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
+static int
+seekOld(
+ Tcl_Channel chan, /* The channel on which to seek. */
+ int offset, /* Offset to seek to. */
+ int mode) /* Relative to which location to seek? */
{
- size_t n = mp_ubin_size(a);
- if (*outlen < (unsigned long)n) {
- return MP_VAL;
- }
- *outlen = (unsigned long)n;
- return mp_to_ubin(a, b, n, NULL);
+ return Tcl_Seek(chan, offset, mode);
}
-mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
+static int
+tellOld(
+ Tcl_Channel chan) /* The channel to return pos for. */
{
- if (maxlen < 0) {
- return MP_VAL;
- }
- return mp_to_radix(a, str, maxlen, NULL, radix);
+ return Tcl_Tell(chan);
}
+#endif /* !TCL_NO_DEPRECATED */
-void bn_reverse(unsigned char *s, int len)
-{
- if (len > 0) {
- s_mp_reverse(s, (size_t)len);
- }
-}
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+#define Tcl_WinUtfToTChar 0
+#define Tcl_WinTCharToUtf 0
+#endif
/*
* WARNING: The contents of this file is automatically generated by the
@@ -485,6 +854,15 @@ void bn_reverse(unsigned char *s, int len)
MODULE_SCOPE const TclStubs tclStubs;
MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/* !BEGIN!: Do not edit below this line. */
static const TclIntStubs tclIntStubs = {
@@ -533,7 +911,7 @@ static const TclIntStubs tclIntStubs = {
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
- 0, /* 43 */
+ TclGetObjInterpProc2, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
@@ -602,22 +980,22 @@ static const TclIntStubs tclIntStubs = {
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
- Tcl_AppendExportList, /* 112 */
- Tcl_CreateNamespace, /* 113 */
- Tcl_DeleteNamespace, /* 114 */
- Tcl_Export, /* 115 */
- Tcl_FindCommand, /* 116 */
- Tcl_FindNamespace, /* 117 */
+ TclAppendExportList, /* 112 */
+ TclCreateNamespace, /* 113 */
+ TclDeleteNamespace, /* 114 */
+ TclExport, /* 115 */
+ TclFindCommand, /* 116 */
+ TclFindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
- Tcl_ForgetImport, /* 121 */
- Tcl_GetCommandFromObj, /* 122 */
- Tcl_GetCommandFullName, /* 123 */
- Tcl_GetCurrentNamespace, /* 124 */
- Tcl_GetGlobalNamespace, /* 125 */
+ TclForgetImport, /* 121 */
+ TclGetCommandFromObj, /* 122 */
+ TclGetCommandFullName, /* 123 */
+ TclGetCurrentNamespace_, /* 124 */
+ TclGetGlobalNamespace_, /* 125 */
Tcl_GetVariableFullName, /* 126 */
- Tcl_Import, /* 127 */
+ TclImport, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
@@ -668,8 +1046,8 @@ static const TclIntStubs tclIntStubs = {
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
+ TclSetStartupScript, /* 178 */
+ TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
@@ -740,18 +1118,18 @@ static const TclIntStubs tclIntStubs = {
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
- TclSetSlaveCancelFlags, /* 250 */
+ TclSetChildCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
- TclStaticPackage, /* 257 */
- 0, /* 258 */
+ TclStaticLibrary, /* 257 */
+ TclpCreateTemporaryDirectory, /* 258 */
0, /* 259 */
- 0, /* 260 */
- TclUnusedStubEntry, /* 261 */
+ TclListTestObj, /* 260 */
+ TclListObjValidate, /* 261 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -865,12 +1243,12 @@ static const TclPlatStubs tclPlatStubs = {
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
0, /* 2 */
- TclUnusedStubEntry, /* 3 */
+ Tcl_WinConvertError, /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_MacOSXOpenBundleResources, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
- TclUnusedStubEntry, /* 2 */
+ Tcl_MacOSXNotifierAddRunLoopMode, /* 2 */
#endif /* MACOSX */
};
@@ -896,7 +1274,7 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_div_2d, /* 16 */
TclBN_mp_div_3, /* 17 */
TclBN_mp_exch, /* 18 */
- TclBN_mp_expt_d, /* 19 */
+ TclBN_mp_expt_u32, /* 19 */
TclBN_mp_grow, /* 20 */
TclBN_mp_init, /* 21 */
TclBN_mp_init_copy, /* 22 */
@@ -924,12 +1302,12 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
- TclBN_mp_unsigned_bin_size, /* 47 */
+ TclBN_mp_ubin_size, /* 47 */
TclBN_mp_xor, /* 48 */
TclBN_mp_zero, /* 49 */
TclBN_reverse, /* 50 */
- TclBN_fast_s_mp_mul_digs, /* 51 */
- TclBN_fast_s_mp_sqr, /* 52 */
+ TclBN_s_mp_mul_digs_fast, /* 51 */
+ TclBN_s_mp_sqr_fast, /* 52 */
TclBN_mp_karatsuba_mul, /* 53 */
TclBN_mp_karatsuba_sqr, /* 54 */
TclBN_mp_toom_mul, /* 55 */
@@ -938,16 +1316,16 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_s_mp_mul_digs, /* 58 */
TclBN_s_mp_sqr, /* 59 */
TclBN_s_mp_sub, /* 60 */
- TclBN_mp_init_set_int, /* 61 */
- TclBN_mp_set_int, /* 62 */
+ TclBN_mp_init_ul, /* 61 */
+ TclBN_mp_set_ul, /* 62 */
TclBN_mp_cnt_lsb, /* 63 */
- TclBNInitBignumFromLong, /* 64 */
- TclBNInitBignumFromWideInt, /* 65 */
- TclBNInitBignumFromWideUInt, /* 66 */
+ TclBN_mp_init_l, /* 64 */
+ TclBN_mp_init_i64, /* 65 */
+ TclBN_mp_init_u64, /* 66 */
TclBN_mp_expt_d_ex, /* 67 */
- TclBN_mp_set_ull, /* 68 */
- TclBN_mp_get_mag_ull, /* 69 */
- TclBN_mp_set_ll, /* 70 */
+ TclBN_mp_set_u64, /* 68 */
+ TclBN_mp_get_mag_u64, /* 69 */
+ TclBN_mp_set_i64, /* 70 */
TclBN_mp_unpack, /* 71 */
TclBN_mp_pack, /* 72 */
TclBN_mp_tc_and, /* 73 */
@@ -1082,7 +1460,7 @@ const TclStubs tclStubs = {
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
- Tcl_CreateSlave, /* 97 */
+ Tcl_CreateChild, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
@@ -1149,7 +1527,7 @@ const TclStubs tclStubs = {
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
- Tcl_GetMaster, /* 164 */
+ Tcl_GetParent, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
@@ -1165,7 +1543,7 @@ const TclStubs tclStubs = {
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
- Tcl_GetSlave, /* 172 */
+ Tcl_GetChild, /* 172 */
Tcl_GetStdChannel, /* 173 */
Tcl_GetStringResult, /* 174 */
Tcl_GetVar, /* 175 */
@@ -1237,7 +1615,7 @@ const TclStubs tclStubs = {
Tcl_SourceRCFile, /* 241 */
Tcl_SplitList, /* 242 */
Tcl_SplitPath, /* 243 */
- Tcl_StaticPackage, /* 244 */
+ Tcl_StaticLibrary, /* 244 */
Tcl_StringMatch, /* 245 */
Tcl_TellOld, /* 246 */
Tcl_TraceVar, /* 247 */
@@ -1319,17 +1697,17 @@ const TclStubs tclStubs = {
Tcl_UniCharToUpper, /* 323 */
Tcl_UniCharToUtf, /* 324 */
Tcl_UtfAtIndex, /* 325 */
- Tcl_UtfCharComplete, /* 326 */
+ TclUtfCharComplete, /* 326 */
Tcl_UtfBackslash, /* 327 */
Tcl_UtfFindFirst, /* 328 */
Tcl_UtfFindLast, /* 329 */
- Tcl_UtfNext, /* 330 */
- Tcl_UtfPrev, /* 331 */
+ TclUtfNext, /* 330 */
+ TclUtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
- Tcl_UtfToUniChar, /* 336 */
+ Tcl_UtfToChar16, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
@@ -1345,10 +1723,10 @@ const TclStubs tclStubs = {
Tcl_UniCharIsSpace, /* 349 */
Tcl_UniCharIsUpper, /* 350 */
Tcl_UniCharIsWordChar, /* 351 */
- Tcl_UniCharLen, /* 352 */
+ Tcl_Char16Len, /* 352 */
Tcl_UniCharNcmp, /* 353 */
- Tcl_UniCharToUtfDString, /* 354 */
- Tcl_UtfToUniCharDString, /* 355 */
+ Tcl_Char16ToUtfDString, /* 354 */
+ Tcl_UtfToChar16DString, /* 355 */
Tcl_GetRegExpFromObj, /* 356 */
Tcl_EvalTokens, /* 357 */
Tcl_FreeParse, /* 358 */
@@ -1624,61 +2002,61 @@ const TclStubs tclStubs = {
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
- 0, /* 631 */
- 0, /* 632 */
- 0, /* 633 */
- 0, /* 634 */
- 0, /* 635 */
- 0, /* 636 */
- 0, /* 637 */
- 0, /* 638 */
- 0, /* 639 */
- 0, /* 640 */
- 0, /* 641 */
- 0, /* 642 */
- 0, /* 643 */
- 0, /* 644 */
- 0, /* 645 */
- 0, /* 646 */
- 0, /* 647 */
- 0, /* 648 */
- 0, /* 649 */
- 0, /* 650 */
- 0, /* 651 */
- 0, /* 652 */
- 0, /* 653 */
- 0, /* 654 */
- 0, /* 655 */
- 0, /* 656 */
- 0, /* 657 */
- 0, /* 658 */
- 0, /* 659 */
- 0, /* 660 */
- 0, /* 661 */
- 0, /* 662 */
- 0, /* 663 */
- 0, /* 664 */
- 0, /* 665 */
- 0, /* 666 */
- 0, /* 667 */
- 0, /* 668 */
- 0, /* 669 */
- 0, /* 670 */
- 0, /* 671 */
- 0, /* 672 */
- 0, /* 673 */
- 0, /* 674 */
- 0, /* 675 */
- 0, /* 676 */
- 0, /* 677 */
- 0, /* 678 */
- 0, /* 679 */
- 0, /* 680 */
- 0, /* 681 */
- 0, /* 682 */
- 0, /* 683 */
- 0, /* 684 */
- 0, /* 685 */
+ Tcl_OpenTcpServerEx, /* 631 */
+ TclZipfs_Mount, /* 632 */
+ TclZipfs_Unmount, /* 633 */
+ TclZipfs_TclLibrary, /* 634 */
+ TclZipfs_MountBuffer, /* 635 */
+ Tcl_FreeInternalRep, /* 636 */
+ Tcl_InitStringRep, /* 637 */
+ Tcl_FetchInternalRep, /* 638 */
+ Tcl_StoreInternalRep, /* 639 */
+ Tcl_HasStringRep, /* 640 */
+ Tcl_IncrRefCount, /* 641 */
+ Tcl_DecrRefCount, /* 642 */
+ Tcl_IsShared, /* 643 */
+ Tcl_LinkArray, /* 644 */
+ Tcl_GetIntForIndex, /* 645 */
+ Tcl_UtfToUniChar, /* 646 */
+ Tcl_UniCharToUtfDString, /* 647 */
+ Tcl_UtfToUniCharDString, /* 648 */
+ TclGetBytesFromObj, /* 649 */
+ Tcl_GetBytesFromObj, /* 650 */
+ TclGetStringFromObj, /* 651 */
+ TclGetUnicodeFromObj, /* 652 */
+ TclGetByteArrayFromObj, /* 653 */
+ Tcl_UtfCharComplete, /* 654 */
+ Tcl_UtfNext, /* 655 */
+ Tcl_UtfPrev, /* 656 */
+ Tcl_UniCharIsUnicode, /* 657 */
+ Tcl_ExternalToUtfDStringEx, /* 658 */
+ Tcl_UtfToExternalDStringEx, /* 659 */
+ Tcl_AsyncMarkFromSignal, /* 660 */
+ TclListObjGetElements, /* 661 */
+ TclListObjLength, /* 662 */
+ TclDictObjSize, /* 663 */
+ TclSplitList, /* 664 */
+ TclSplitPath, /* 665 */
+ TclFSSplitPath, /* 666 */
+ TclParseArgsObjv, /* 667 */
+ Tcl_UniCharLen, /* 668 */
+ TclNumUtfChars, /* 669 */
+ TclGetCharLength, /* 670 */
+ TclUtfAtIndex, /* 671 */
+ TclGetRange, /* 672 */
+ TclGetUniChar, /* 673 */
+ Tcl_GetBool, /* 674 */
+ Tcl_GetBoolFromObj, /* 675 */
+ Tcl_CreateObjCommand2, /* 676 */
+ Tcl_CreateObjTrace2, /* 677 */
+ Tcl_NRCreateCommand2, /* 678 */
+ Tcl_NRCallObjProc2, /* 679 */
+ Tcl_GetNumberFromObj, /* 680 */
+ Tcl_GetNumber, /* 681 */
+ Tcl_RemoveChannelMode, /* 682 */
+ Tcl_GetEncodingNulLength, /* 683 */
+ Tcl_GetWideUIntFromObj, /* 684 */
+ Tcl_DStringToObj, /* 685 */
0, /* 686 */
TclUnusedStubEntry, /* 687 */
};
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index bebea81..f06b2d1 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -4,8 +4,8 @@
* 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.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 1998 Paul Duffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,20 +17,19 @@ MODULE_SCOPE const TclStubs *tclStubsPtr;
MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr;
MODULE_SCOPE const TclIntStubs *tclIntStubsPtr;
MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr;
+MODULE_SCOPE void *tclStubsHandle;
const TclStubs *tclStubsPtr = NULL;
const TclPlatStubs *tclPlatStubsPtr = NULL;
const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
+void *tclStubsHandle = NULL;
/*
- * Use our own isDigit to avoid linking to libc on windows
+ * Use our own ISDIGIT to avoid linking to libc on windows
*/
-static int isDigit(const int c)
-{
- return (c >= '0' && c <= '9');
-}
+#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9)
/*
*----------------------------------------------------------------------
@@ -54,35 +53,39 @@ MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
- int exact)
+ int exact,
+ int magic)
{
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
const char *actualVersion = NULL;
- ClientData pkgData = NULL;
+ void *pkgData = NULL;
const TclStubs *stubsPtr = iPtr->stubTable;
+ const char *tclName = (((exact&0xFF00) >= 0x900) ? "tcl" : "Tcl");
+#undef TCL_STUB_MAGIC /* We need the TCL_STUB_MAGIC from Tcl 8.x here */
+#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
- if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
+ if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
- iPtr->freeProc = TCL_STATIC;
+ iPtr->freeProc = 0; /* TCL_STATIC */
return NULL;
}
- actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
+ actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
- if (exact) {
+ if (exact&1) {
const char *p = version;
int count = 0;
while (*p) {
- count += !isDigit(*p++);
+ count += !ISDIGIT(*p++);
}
if (count == 1) {
const char *q = actualVersion;
@@ -91,24 +94,31 @@ Tcl_InitStubs(
while (*p && (*p == *q)) {
p++; q++;
}
- if (*p || isDigit(*q)) {
+ if (*p || ISDIGIT(*q)) {
/* Construct error message */
- stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+ stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
return NULL;
}
} else {
- actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+ actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
- tclStubsPtr = (TclStubs *)pkgData;
+ if (((exact&0xFF00) < 0x900)) {
+ /* We are running Tcl 8.x */
+ stubsPtr = (TclStubs *)pkgData;
+ }
+ if (tclStubsHandle == NULL) {
+ tclStubsHandle = INT2PTR(-1);
+ }
+ tclStubsPtr = stubsPtr;
- if (tclStubsPtr->hooks) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
+ if (stubsPtr->hooks) {
+ tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
+ tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
+ tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index bc51c99..f4450ff 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6,20 +6,33 @@
* commands are not normally included in Tcl applications; they're only
* used for testing.
*
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Ajuba Solutions.
- * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1993-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions.
+ * Copyright © 2003 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.
*/
#undef STATIC_BUILD
+#undef BUILD_tcl
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
+#undef TCL_UTF_MAX
+#ifdef TCL_NO_DEPRECATED
+# define TCL_UTF_MAX 4
+#else
+# define TCL_NO_DEPRECATED
+# define TCL_UTF_MAX 3
+#endif
#include "tclInt.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
#include "tclOO.h"
#include <math.h>
@@ -29,29 +42,17 @@
#include "tclRegexp.h"
/*
- * Required for TestlocaleCmd
- */
-#include <locale.h>
-
-/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
-/*
- * Declare external functions used in Windows tests.
- */
+#include "tclUuid.h"
/*
- * 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.
+ * Declare external functions used in Windows tests.
*/
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-EXTERN int Tcltest_Init(Tcl_Interp *interp);
-EXTERN int Tcltest_SafeInit(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
@@ -62,6 +63,21 @@ static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
+ * One of the following structures exists for each command created by the
+ * "testcmdtoken" command.
+ */
+
+typedef struct TestCommandTokenRef {
+ int id; /* Identifier for this reference. */
+ Tcl_Command token; /* Tcl's token for the command. */
+ struct TestCommandTokenRef *nextPtr;
+ /* Next in list of references. */
+} TestCommandTokenRef;
+
+static TestCommandTokenRef *firstCommandTokenRef = NULL;
+static int nextCommandTokenRefId = 1;
+
+/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
@@ -75,6 +91,17 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
+/*
+ * Start of the socket driver state structure to acces field testFlags
+ */
+
+typedef struct TcpState TcpState;
+
+struct TcpState {
+ Tcl_Channel channel; /* Channel associated with this socket. */
+ int flags; /* ORed combination of various bitfields. */
+};
+
TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
@@ -120,7 +147,9 @@ typedef struct {
* was called for a result.
*/
+#ifndef TCL_NO_DEPRECATED
static int freeCount;
+#endif /* TCL_NO_DEPRECATED */
/*
* Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
@@ -151,67 +180,76 @@ typedef struct TestChannel {
static TestChannel *firstDetached;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/*
* Forward declarations for procedures defined later in this file:
*/
-static int AsyncHandlerProc(ClientData clientData,
+static int AsyncHandlerProc(void *clientData,
Tcl_Interp *interp, int code);
-#ifdef TCL_THREADS
-static Tcl_ThreadCreateType AsyncThreadProc(ClientData);
-#endif
+static Tcl_ThreadCreateType AsyncThreadProc(void *);
static void CleanupTestSetassocdataTests(
- ClientData clientData, Tcl_Interp *interp);
-static void CmdDelProc1(ClientData clientData);
-static void CmdDelProc2(ClientData clientData);
+ void *clientData, Tcl_Interp *interp);
+static void CmdDelProc1(void *clientData);
+static void CmdDelProc2(void *clientData);
static Tcl_CmdProc CmdProc1;
static Tcl_CmdProc CmdProc2;
static void CmdTraceDeleteProc(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
- ClientData cmdClientData, int argc,
+ void *cmdClientData, int argc,
const char *argv[]);
-static void CmdTraceProc(ClientData clientData,
+static void CmdTraceProc(void *clientData,
Tcl_Interp *interp, int level, char *command,
- Tcl_CmdProc *cmdProc, ClientData cmdClientData,
+ Tcl_CmdProc *cmdProc, void *cmdClientData,
int argc, const char *argv[]);
static Tcl_CmdProc CreatedCommandProc;
static Tcl_CmdProc CreatedCommandProc2;
-static void DelCallbackProc(ClientData clientData,
+static void DelCallbackProc(void *clientData,
Tcl_Interp *interp);
static Tcl_CmdProc DelCmdProc;
-static void DelDeleteProc(ClientData clientData);
-static void EncodingFreeProc(ClientData clientData);
-static int EncodingToUtfProc(ClientData clientData,
+static void DelDeleteProc(void *clientData);
+static void EncodingFreeProc(void *clientData);
+static int EncodingToUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static int EncodingFromUtfProc(ClientData clientData,
+static int EncodingFromUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static void ExitProcEven(ClientData clientData);
-static void ExitProcOdd(ClientData clientData);
+static void ExitProcEven(void *clientData);
+static void ExitProcOdd(void *clientData);
static Tcl_ObjCmdProc GetTimesObjCmd;
+static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver;
static void MainLoop(void);
static Tcl_CmdProc NoopCmd;
static Tcl_ObjCmdProc NoopObjCmd;
-static int ObjTraceProc(ClientData clientData,
+static int ObjTraceProc(void *clientData,
Tcl_Interp *interp, int level, const char *command,
Tcl_Command commandToken, int objc,
Tcl_Obj *const objv[]);
-static void ObjTraceDeleteProc(ClientData clientData);
+static void ObjTraceDeleteProc(void *clientData);
static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void SpecialFree(char *blockPtr);
static int StaticInitProc(Tcl_Interp *interp);
static Tcl_CmdProc TestasyncCmd;
static Tcl_ObjCmdProc TestbumpinterpepochObjCmd;
+static Tcl_ObjCmdProc TestbytestringObjCmd;
static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd;
static Tcl_ObjCmdProc TestpurebytesobjObjCmd;
-static Tcl_ObjCmdProc TestbytestringObjCmd;
static Tcl_ObjCmdProc TeststringbytesObjCmd;
+static Tcl_ObjCmdProc Testutf16stringObjCmd;
static Tcl_CmdProc TestcmdinfoCmd;
static Tcl_CmdProc TestcmdtokenCmd;
static Tcl_CmdProc TestcmdtraceCmd;
@@ -228,7 +266,7 @@ static Tcl_ObjCmdProc TestevalobjvObjCmd;
static Tcl_ObjCmdProc TesteventObjCmd;
static int TesteventProc(Tcl_Event *event, int flags);
static int TesteventDeleteProc(Tcl_Event *event,
- ClientData clientData);
+ void *clientData);
static Tcl_CmdProc TestexithandlerCmd;
static Tcl_CmdProc TestexprlongCmd;
static Tcl_ObjCmdProc TestexprlongobjCmd;
@@ -241,17 +279,14 @@ static Tcl_ObjCmdProc TestfilelinkCmd;
static Tcl_CmdProc TestfeventCmd;
static Tcl_CmdProc TestgetassocdataCmd;
static Tcl_CmdProc TestgetintCmd;
+static Tcl_CmdProc TestlongsizeCmd;
static Tcl_CmdProc TestgetplatformCmd;
static Tcl_ObjCmdProc TestgetvarfullnameCmd;
static Tcl_CmdProc TestinterpdeleteCmd;
static Tcl_CmdProc TestlinkCmd;
+static Tcl_ObjCmdProc TestlinkarrayCmd;
+static Tcl_ObjCmdProc TestlistrepCmd;
static Tcl_ObjCmdProc TestlocaleCmd;
-static int TestMathFunc(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-static int TestMathFunc2(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
static Tcl_CmdProc TestmainthreadCmd;
static Tcl_CmdProc TestsetmainloopCmd;
static Tcl_CmdProc TestexitmainloopCmd;
@@ -260,29 +295,36 @@ static Tcl_ObjCmdProc TestparseargsCmd;
static Tcl_ObjCmdProc TestparserObjCmd;
static Tcl_ObjCmdProc TestparsevarObjCmd;
static Tcl_ObjCmdProc TestparsevarnameObjCmd;
+static Tcl_ObjCmdProc TestpreferstableObjCmd;
+static Tcl_ObjCmdProc TestprintObjCmd;
static Tcl_ObjCmdProc TestregexpObjCmd;
static Tcl_ObjCmdProc TestreturnObjCmd;
static void TestregexpXflags(const char *string,
- int length, int *cflagsPtr, int *eflagsPtr);
+ size_t length, int *cflagsPtr, int *eflagsPtr);
+#ifndef TCL_NO_DEPRECATED
static Tcl_ObjCmdProc TestsaveresultCmd;
static void TestsaveresultFree(char *blockPtr);
+#endif /* TCL_NO_DEPRECATED */
static Tcl_CmdProc TestsetassocdataCmd;
static Tcl_CmdProc TestsetCmd;
static Tcl_CmdProc Testset2Cmd;
static Tcl_CmdProc TestseterrorcodeCmd;
static Tcl_ObjCmdProc TestsetobjerrorcodeCmd;
static Tcl_CmdProc TestsetplatformCmd;
-static Tcl_CmdProc TeststaticpkgCmd;
+static Tcl_CmdProc TeststaticlibraryCmd;
static Tcl_CmdProc TesttranslatefilenameCmd;
static Tcl_CmdProc TestupvarCmd;
static Tcl_ObjCmdProc TestWrongNumArgsObjCmd;
static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd;
static Tcl_CmdProc TestChannelCmd;
static Tcl_CmdProc TestChannelEventCmd;
+static Tcl_CmdProc TestSocketCmd;
static Tcl_ObjCmdProc TestFilesystemObjCmd;
static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd;
static void TestReport(const char *cmd, Tcl_Obj *arg1,
Tcl_Obj *arg2);
+static Tcl_ObjCmdProc TestgetencpathObjCmd;
+static Tcl_ObjCmdProc TestsetencpathObjCmd;
static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr);
static Tcl_FSStatProc TestReportStat;
static Tcl_FSAccessProc TestReportAccess;
@@ -321,6 +363,7 @@ static Tcl_ObjCmdProc TestNumUtfCharsCmd;
static Tcl_ObjCmdProc TestFindFirstCmd;
static Tcl_ObjCmdProc TestFindLastCmd;
static Tcl_ObjCmdProc TestHashSystemHashCmd;
+static Tcl_ObjCmdProc TestGetIntForIndexCmd;
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
@@ -432,14 +475,87 @@ static const Tcl_Filesystem simpleFilesystem = {
*----------------------------------------------------------------------
*/
+#ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+#endif
+
+static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID)
+#if defined(__clang__) && defined(__clang_major__)
+ ".clang-" STRINGIFY(__clang_major__)
+#if __clang_minor__ < 10
+ "0"
+#endif
+ STRINGIFY(__clang_minor__)
+#endif
+#ifdef TCL_COMPILE_DEBUG
+ ".compiledebug"
+#endif
+#ifdef TCL_COMPILE_STATS
+ ".compilestats"
+#endif
+#if defined(__cplusplus) && !defined(__OBJC__)
+ ".cplusplus"
+#endif
+#ifndef NDEBUG
+ ".debug"
+#endif
+#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
+ ".gcc-" STRINGIFY(__GNUC__)
+#if __GNUC_MINOR__ < 10
+ "0"
+#endif
+ STRINGIFY(__GNUC_MINOR__)
+#endif
+#ifdef __INTEL_COMPILER
+ ".icc-" STRINGIFY(__INTEL_COMPILER)
+#endif
+#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL)
+ ".ilp32"
+#endif
+#ifdef TCL_MEM_DEBUG
+ ".memdebug"
+#endif
+#if defined(_MSC_VER)
+ ".msvc-" STRINGIFY(_MSC_VER)
+#endif
+#ifdef USE_NMAKE
+ ".nmake"
+#endif
+#if !TCL_THREADS
+ ".no-thread"
+#endif
+#ifndef TCL_CFG_OPTIMIZED
+ ".no-optimize"
+#endif
+#ifdef __OBJC__
+ ".objective-c"
+#if defined(__cplusplus)
+ "plusplus"
+#endif
+#endif
+#ifdef TCL_CFG_PROFILED
+ ".profile"
+#endif
+#ifdef PURIFY
+ ".purify"
+#endif
+#ifdef STATIC_BUILD
+ ".static"
+#endif
+#if TCL_UTF_MAX < 4
+ ".utf-16"
+#endif
+;
+
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
- Tcl_ValueType t3ArgTypes[2];
-
+ Tcl_CmdInfo info;
Tcl_Obj **objv, *objPtr;
- int objc, index;
+ Tcl_Size objc;
+ int index;
static const char *const specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
@@ -448,15 +564,26 @@ Tcltest_Init(
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
- if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
+#ifndef TCL_WITH_EXTERNAL_TOMMATH
+ if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
+#endif
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) {
+ if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
+#if TCL_MAJOR_VERSION > 8
+ if (info.isNativeObjectProc == 2) {
+ Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
+ info.objProc2, (void *)version, NULL);
+ } else
+#endif
+ Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
+ info.objProc, (void *)version, NULL);
+ }
+ if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -471,6 +598,7 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -539,6 +667,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
@@ -546,6 +676,8 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
@@ -556,12 +688,18 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
+ NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
+#endif
Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
@@ -569,9 +707,9 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
@@ -586,15 +724,17 @@ Tcltest_Init(
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testgetintforindex",
+ TestGetIntForIndexCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
+ Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
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, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -605,17 +745,16 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
NULL, NULL);
#endif
- t3ArgTypes[0] = TCL_EITHER;
- t3ArgTypes[1] = TCL_EITHER;
- Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- NULL);
-
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd,
+ NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
NULL, NULL);
@@ -625,7 +764,7 @@ Tcltest_Init(
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
@@ -655,7 +794,7 @@ Tcltest_Init(
return TCL_ERROR;
}
case 3:
- if (objc-1) {
+ if (objc > 1) {
Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1],
TCL_GLOBAL_ONLY);
}
@@ -694,9 +833,24 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
+ Tcl_CmdInfo info;
+
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
+ if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
+#if TCL_MAJOR_VERSION > 8
+ if (info.isNativeObjectProc == 2) {
+ Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
+ info.objProc2, (void *)version, NULL);
+ } else
+#endif
+ Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
+ info.objProc, (void *)version, NULL);
+ }
+ if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
return Procbodytest_SafeInit(interp);
}
@@ -719,7 +873,7 @@ Tcltest_SafeInit(
static int
TestasyncCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -727,7 +881,6 @@ TestasyncCmd(
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- (void)dummy;
if (argc < 2) {
wrongNumArgs:
@@ -749,7 +902,7 @@ TestasyncCmd(
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
@@ -802,10 +955,9 @@ TestasyncCmd(
break;
}
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
-#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -833,19 +985,13 @@ TestasyncCmd(
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
return TCL_ERROR;
-#else /* !TCL_THREADS */
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, int, or mark", NULL);
- return TCL_ERROR;
-#endif
}
return TCL_OK;
}
static int
AsyncHandlerProc(
- ClientData clientData, /* If of TestAsyncHandler structure.
+ void *clientData, /* If of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
@@ -853,7 +999,8 @@ AsyncHandlerProc(
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
- const char *listArgv[4], *cmd;
+ const char *listArgv[4];
+ char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
@@ -877,7 +1024,7 @@ AsyncHandlerProc(
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
- code = Tcl_EvalEx(interp, cmd, -1, 0);
+ code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
@@ -904,10 +1051,9 @@ AsyncHandlerProc(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
static Tcl_ThreadCreateType
AsyncThreadProc(
- ClientData clientData) /* Parameter is the id of a
+ void *clientData) /* Parameter is the id of a
* TestAsyncHandler, defined above. */
{
TestAsyncHandler *asyncPtr;
@@ -926,11 +1072,10 @@ AsyncThreadProc(
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
-#endif
static int
TestbumpinterpepochObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -965,13 +1110,12 @@ TestbumpinterpepochObjCmd(
static int
TestcmdinfoCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
- (void)dummy;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -979,7 +1123,7 @@ TestcmdinfoCmd(
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
+ Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
@@ -1016,15 +1160,15 @@ TestcmdinfoCmd(
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
- info.clientData = (ClientData) "new_command_data";
+ info.clientData = (void *) "new_command_data";
info.objProc = NULL;
info.objClientData = NULL;
info.deleteProc = CmdDelProc2;
- info.deleteData = (ClientData) "new_delete_data";
+ info.deleteData = (void *) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
@@ -1036,10 +1180,10 @@ TestcmdinfoCmd(
static int
CmdProc1(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL);
return TCL_OK;
@@ -1047,10 +1191,10 @@ CmdProc1(
static int
CmdProc2(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL);
return TCL_OK;
@@ -1058,20 +1202,20 @@ CmdProc2(
static void
CmdDelProc1(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
- Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
static void
CmdDelProc2(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
- Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
/*
@@ -1093,14 +1237,14 @@ CmdDelProc2(
static int
TestcmdtokenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- Tcl_Command token;
- int *l;
+ TestCommandTokenRef *refPtr;
char buf[30];
+ int id;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -1108,24 +1252,42 @@ TestcmdtokenCmd(
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
- (ClientData) "original", NULL);
- sprintf(buf, "%p", (void *)token);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
+ refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
+ (void *) "original", NULL);
+ refPtr->id = nextCommandTokenRefId;
+ nextCommandTokenRefId++;
+ refPtr->nextPtr = firstCommandTokenRef;
+ firstCommandTokenRef = refPtr;
+ sprintf(buf, "%d", refPtr->id);
+ Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
- if (sscanf(argv[2], "%p", &l) != 1) {
+ if (sscanf(argv[2], "%d", &id) != 1) {
+ Tcl_AppendResult(interp, "bad command token \"", argv[2],
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ for (refPtr = firstCommandTokenRef; refPtr != NULL;
+ refPtr = refPtr->nextPtr) {
+ if (refPtr->id == id) {
+ break;
+ }
+ }
+
+ if (refPtr == NULL) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", NULL);
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
- Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
+ Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
Tcl_AppendElement(interp,
- Tcl_GetCommandName(interp, (Tcl_Command) l));
+ Tcl_GetCommandName(interp, refPtr->token));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
@@ -1156,7 +1318,7 @@ TestcmdtokenCmd(
static int
TestcmdtraceCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1173,7 +1335,7 @@ TestcmdtraceCmd(
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1189,13 +1351,13 @@ TestcmdtraceCmd(
*/
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
- Tcl_EvalEx(interp, argv[2], -1, 0);
+ Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
&buffer);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1212,11 +1374,11 @@ TestcmdtraceCmd(
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
- (ClientData) &deleteCalled, ObjTraceDeleteProc);
- result = Tcl_Eval(interp, argv[2]);
+ &deleteCalled, ObjTraceDeleteProc);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
- Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
+ Tcl_AppendResult(interp, "Delete wasn't called", NULL);
return TCL_ERROR;
} else {
return result;
@@ -1227,7 +1389,7 @@ TestcmdtraceCmd(
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1245,16 +1407,15 @@ TestcmdtraceCmd(
static void
CmdTraceProc(
- ClientData clientData, /* Pointer to buffer in which the
+ void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
- Tcl_Interp *interp, /* Current interpreter. */
- int level, /* Current trace level. */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*level*/,
char *command, /* The command being traced (after
* substitutions). */
- Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
- * procedure. */
+ TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
+ TCL_UNUSED(void *),
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
@@ -1272,16 +1433,14 @@ CmdTraceProc(
static void
CmdTraceDeleteProc(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int level, /* Current trace level. */
- char *command, /* The command being traced (after
- * substitutions). */
- Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
- * procedure. */
- int argc, /* Number of arguments. */
- const char *argv[]) /* Argument strings. */
+ TCL_UNUSED(int) /*level*/,
+ TCL_UNUSED(char *) /*command*/,
+ TCL_UNUSED(Tcl_CmdProc *),
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
@@ -1294,18 +1453,18 @@ CmdTraceDeleteProc(
static int
ObjTraceProc(
- ClientData clientData, /* unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
- int level, /* Execution level */
- const char *command, /* Command being executed */
- Tcl_Command token, /* Command information */
- int objc, /* Parameter count */
- Tcl_Obj *const objv[]) /* Parameter list */
+ TCL_UNUSED(int) /*level*/,
+ const char *command,
+ TCL_UNUSED(Tcl_Command),
+ TCL_UNUSED(int) /*objc*/,
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE));
return TCL_ERROR;
} else if (!strcmp(word, "Break")) {
return TCL_BREAK;
@@ -1322,7 +1481,7 @@ ObjTraceProc(
static void
ObjTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
@@ -1351,7 +1510,7 @@ ObjTraceDeleteProc(
static int
TestcreatecommandCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1381,10 +1540,10 @@ TestcreatecommandCmd(
static int
CreatedCommandProc(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
@@ -1403,10 +1562,10 @@ CreatedCommandProc(
static int
CreatedCommandProc2(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
@@ -1441,7 +1600,7 @@ CreatedCommandProc2(
static int
TestdcallCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1456,10 +1615,10 @@ TestdcallCmd(
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(-id));
+ INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(id));
+ INT2PTR(id));
}
}
Tcl_DeleteInterp(delInterp);
@@ -1473,7 +1632,7 @@ TestdcallCmd(
static void
DelCallbackProc(
- ClientData clientData, /* Numerical value to append to delString. */
+ void *clientData, /* Numerical value to append to delString. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
int id = PTR2INT(clientData);
@@ -1505,7 +1664,7 @@ DelCallbackProc(
static int
TestdelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1514,7 +1673,7 @@ TestdelCmd(
Tcl_Interp *child;
if (argc != 4) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
@@ -1528,17 +1687,17 @@ TestdelCmd(
dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
- Tcl_CreateCommand(child, argv[2], DelCmdProc, (ClientData) dPtr,
+ Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
- ClientData clientData, /* String result to return. */
+ void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
DelCmd *dPtr = (DelCmd *) clientData;
@@ -1550,11 +1709,11 @@ DelCmdProc(
static void
DelDeleteProc(
- ClientData clientData) /* String command to evaluate. */
+ void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
- Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
+ Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
@@ -1580,7 +1739,7 @@ DelDeleteProc(
static int
TestdelassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1609,32 +1768,27 @@ TestdelassocdataCmd(
* Parameters:
* fpval - Floating-point value to format.
* ndigits - Digit count to request from Tcl_DoubleDigits
- * type - One of 'shortest', 'Steele', 'e', 'f'
+ * type - One of 'shortest', 'e', 'f'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
-TestdoubledigitsObjCmd(ClientData unused,
- /* NULL */
- Tcl_Interp* interp,
- /* Tcl interpreter */
- int objc,
- /* Parameter count */
- Tcl_Obj* const objv[])
- /* Parameter vector */
+TestdoubledigitsObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char *options[] = {
"shortest",
- "Steele",
"e",
"f",
NULL
};
static const int types[] = {
TCL_DD_SHORTEST,
- TCL_DD_STEELE,
TCL_DD_E_FORMAT,
TCL_DD_F_FORMAT
};
@@ -1646,7 +1800,7 @@ TestdoubledigitsObjCmd(ClientData unused,
int type;
int decpt;
int signum;
- char * str;
+ char *str;
char *endPtr;
Tcl_Obj* strObj;
Tcl_Obj* retval;
@@ -1658,8 +1812,8 @@ TestdoubledigitsObjCmd(ClientData unused,
status = Tcl_GetDoubleFromObj(interp, objv[1], &d);
if (status != TCL_OK) {
doubleType = Tcl_GetObjType("double");
- if (objv[1]->typePtr == doubleType
- || TclIsNaN(objv[1]->internalRep.doubleValue)) {
+ if (Tcl_FetchInternalRep(objv[1], doubleType)
+ && isnan(objv[1]->internalRep.doubleValue)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
@@ -1674,16 +1828,16 @@ TestdoubledigitsObjCmd(ClientData unused,
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE));
return TCL_ERROR;
}
- type |= TCL_DD_SHORTEN_FLAG;
+ type |= TCL_DD_SHORTEST;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
ckfree(str);
retval = Tcl_NewListObj(1, &strObj);
- Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
+ Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt));
strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
Tcl_ListObjAppendElement(NULL, retval, strObj);
Tcl_SetObjResult(interp, retval);
@@ -1709,7 +1863,7 @@ TestdoubledigitsObjCmd(ClientData unused,
static int
TestdstringCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1718,7 +1872,7 @@ TestdstringCmd(
if (argc < 2) {
wrongNumArgs:
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "append") == 0) {
@@ -1754,11 +1908,11 @@ TestdstringCmd(
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
- Tcl_SetResult(interp, "short", TCL_STATIC);
+ Tcl_AppendResult(interp, "short", NULL);
} 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);
+ Tcl_AppendResult(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", NULL);
} else if (strcmp(argv[2], "free") == 0) {
- char *s = ckalloc(100);
+ char *s = (char *)ckalloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
@@ -1777,12 +1931,17 @@ TestdstringCmd(
if (argc != 2) {
goto wrongNumArgs;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringResult(interp, &dstring);
+ } else if (strcmp(argv[1], "toobj") == 0) {
+ if (argc != 2) {
+ goto wrongNumArgs;
+ }
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring));
} else if (strcmp(argv[1], "trunc") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -1798,8 +1957,8 @@ TestdstringCmd(
Tcl_DStringStartSublist(&dstring);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be append, element, end, free, get, length, "
- "result, trunc, or start", NULL);
+ "\": must be append, element, end, free, get, gresult, length, "
+ "result, start, toobj, or trunc", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1810,9 +1969,9 @@ TestdstringCmd(
* Tcl_DStringGetResult handles freeProc's other than free.
*/
-static void SpecialFree(blockPtr)
- char *blockPtr; /* Block to free. */
-{
+static void SpecialFree(
+ char *blockPtr /* Block to free. */
+) {
ckfree(blockPtr - 16);
}
@@ -1835,7 +1994,7 @@ static void SpecialFree(blockPtr)
static int
TestencodingObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1845,12 +2004,17 @@ TestencodingObjCmd(
const char *string;
TclEncoding *encodingPtr;
static const char *const optionStrings[] = {
- "create", "delete", NULL
+ "create", "delete", "nullength", NULL
};
enum options {
- ENC_CREATE, ENC_DELETE
+ ENC_CREATE, ENC_DELETE, ENC_NULLENGTH
};
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?args?");
+ return TCL_ERROR;
+ }
+
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
@@ -1861,9 +2025,10 @@ TestencodingObjCmd(
Tcl_EncodingType type;
if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name toutfcmd fromutfcmd");
return TCL_ERROR;
}
- encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding));
+ encodingPtr = (TclEncoding*)ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
@@ -1880,7 +2045,7 @@ TestencodingObjCmd(
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
type.freeProc = EncodingFreeProc;
- type.clientData = (ClientData) encodingPtr;
+ type.clientData = encodingPtr;
type.nullSize = 1;
Tcl_CreateEncoding(&type);
@@ -1890,21 +2055,38 @@ TestencodingObjCmd(
if (objc != 3) {
return TCL_ERROR;
}
- encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
- Tcl_FreeEncoding(encoding);
- Tcl_FreeEncoding(encoding);
+ if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) {
+ return TCL_ERROR;
+ }
+ Tcl_FreeEncoding(encoding); /* Free returned reference */
+ Tcl_FreeEncoding(encoding); /* Free to match CREATE */
+ TclFreeInternalRep(objv[2]); /* Free the cached ref */
break;
+
+ case ENC_NULLENGTH:
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
+ return TCL_ERROR;
+ }
+ encoding =
+ Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2]));
+ if (encoding == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp,
+ Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding)));
+ Tcl_FreeEncoding(encoding);
}
return TCL_OK;
}
static int
EncodingToUtfProc(
- ClientData clientData, /* TclEncoding structure. */
- const char *src, /* Source string in specified encoding. */
+ void *clientData, /* TclEncoding structure. */
+ TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
- int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Current state. */
+ TCL_UNUSED(int) /*flags*/,
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
@@ -1915,7 +2097,7 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -1932,11 +2114,11 @@ EncodingToUtfProc(
static int
EncodingFromUtfProc(
- ClientData clientData, /* TclEncoding structure. */
- const char *src, /* Source string in specified encoding. */
+ void *clientData, /* TclEncoding structure. */
+ TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
- int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Current state. */
+ TCL_UNUSED(int) /*flags*/,
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
@@ -1947,7 +2129,7 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -1964,7 +2146,7 @@ EncodingFromUtfProc(
static void
EncodingFreeProc(
- ClientData clientData) /* ClientData associated with type. */
+ void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
@@ -1992,7 +2174,7 @@ EncodingFreeProc(
static int
TestevalexObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2037,7 +2219,7 @@ TestevalexObjCmd(
static int
TestevalobjvObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2086,7 +2268,7 @@ TestevalobjvObjCmd(
static int
TesteventObjCmd(
- ClientData unused, /* Not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -2099,7 +2281,7 @@ TesteventObjCmd(
"head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
- static const Tcl_QueuePosition posNum[] = {
+ static const int posNum[] = {
/* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
@@ -2171,7 +2353,7 @@ TesteventObjCmd(
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
- int flags) /* Current flags for Tcl_ServiceEvent */
+ TCL_UNUSED(int) /*flags*/)
{
TestEvent *ev = (TestEvent *) event;
Tcl_Interp *interp = ev->interp;
@@ -2183,14 +2365,14 @@ TesteventProc(
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (command bound to \"testevent\" callback)");
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, TCL_ERROR);
return 1; /* Avoid looping on errors */
}
if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),
&retval) != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (return value from \"testevent\" callback)");
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, TCL_ERROR);
return 1;
}
if (retval) {
@@ -2222,7 +2404,7 @@ TesteventProc(
static int
TesteventDeleteProc(
Tcl_Event *event, /* Event to examine */
- ClientData clientData) /* Tcl_Obj containing the name of the event(s)
+ void *clientData) /* Tcl_Obj containing the name of the event(s)
* to remove */
{
TestEvent *ev; /* Event to examine */
@@ -2265,7 +2447,7 @@ TesteventDeleteProc(
static int
TestexithandlerCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2282,10 +2464,10 @@ TestexithandlerCmd(
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or delete", NULL);
@@ -2296,7 +2478,7 @@ TestexithandlerCmd(
static void
ExitProcOdd(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
@@ -2310,7 +2492,7 @@ ExitProcOdd(
static void
ExitProcEven(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
@@ -2341,7 +2523,7 @@ ExitProcEven(
static int
TestexprlongCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2355,7 +2537,7 @@ TestexprlongCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLong(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2384,7 +2566,7 @@ TestexprlongCmd(
static int
TestexprlongobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2397,7 +2579,7 @@ TestexprlongobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2426,7 +2608,7 @@ TestexprlongobjCmd(
static int
TestexprdoubleCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2440,7 +2622,7 @@ TestexprdoubleCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDouble(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2470,7 +2652,7 @@ TestexprdoubleCmd(
static int
TestexprdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2483,7 +2665,7 @@ TestexprdoubleobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2512,7 +2694,7 @@ TestexprdoubleobjCmd(
static int
TestexprstringCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2544,7 +2726,7 @@ TestexprstringCmd(
static int
TestfilelinkCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -2611,7 +2793,7 @@ TestfilelinkCmd(
static int
TestgetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2649,7 +2831,7 @@ TestgetassocdataCmd(
static int
TestgetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2689,7 +2871,7 @@ TestgetplatformCmd(
static int
TestinterpdeleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2729,7 +2911,7 @@ TestinterpdeleteCmd(
static int
TestlinkCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2737,7 +2919,7 @@ TestlinkCmd(
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
- static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
+ static Tcl_WideInt wideVar = 79;
static char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
@@ -2747,7 +2929,7 @@ TestlinkCmd(
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
- static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
+ static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
@@ -2787,112 +2969,112 @@ TestlinkCmd(
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "int", (char *) &intVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "int", &intVar,
TCL_LINK_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "real", (char *) &realVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "real", &realVar,
TCL_LINK_DOUBLE | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "bool", &boolVar,
TCL_LINK_BOOLEAN | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "string", &stringVar,
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "wide", &wideVar,
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "char", (char *) &charVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "char", &charVar,
TCL_LINK_CHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uchar", &ucharVar,
TCL_LINK_UCHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "short", (char *) &shortVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "short", &shortVar,
TCL_LINK_SHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "ushort", &ushortVar,
TCL_LINK_USHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uint", (char *) &uintVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uint", &uintVar,
TCL_LINK_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "long", (char *) &longVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "long", &longVar,
TCL_LINK_LONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "ulong", &ulongVar,
TCL_LINK_ULONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "float", (char *) &floatVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "float", &floatVar,
TCL_LINK_FLOAT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) {
return TCL_ERROR;
}
- flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar,
+ flag = writable ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uwide", &uwideVar,
TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -2937,15 +3119,32 @@ TestlinkCmd(
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, (int) uintVar);
Tcl_AppendElement(interp, buffer);
- tmp = Tcl_NewLongObj(longVar);
+ tmp = Tcl_NewWideIntObj(longVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
- tmp = Tcl_NewLongObj((long)ulongVar);
+#ifdef TCL_WIDE_INT_IS_LONG
+ if (ulongVar > WIDE_MAX) {
+ mp_int bignumValue;
+ if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) {
+ Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
+ }
+ tmp = Tcl_NewBignumObj(&bignumValue);
+ } else
+#endif /* TCL_WIDE_INT_IS_LONG */
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
Tcl_PrintDouble(NULL, (double)floatVar, buffer);
Tcl_AppendElement(interp, buffer);
- tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ if (uwideVar > WIDE_MAX) {
+ mp_int bignumValue;
+ if (mp_init_u64(&bignumValue, uwideVar) != MP_OKAY) {
+ Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
+ }
+ tmp = Tcl_NewBignumObj(&bignumValue);
+ } else {
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ }
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
@@ -2986,7 +3185,7 @@ TestlinkCmd(
}
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3044,7 +3243,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3094,7 +3293,7 @@ TestlinkCmd(
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3161,7 +3360,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3181,75 +3380,131 @@ TestlinkCmd(
/*
*----------------------------------------------------------------------
*
- * TestlocaleCmd --
+ * TestlinkarrayCmd --
*
- * This procedure implements the "testlocale" command. It is used
- * to test the effects of setting different locales in Tcl.
+ * This function is invoked to process the "testlinkarray" Tcl command.
+ * It is used to test the 'Tcl_LinkArray' function.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * Modifies the current C locale.
+ * Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
static int
-TestlocaleCmd(
- ClientData clientData, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* The argument objects. */
-{
- int index;
- const char *locale;
-
- static const char *const optionStrings[] = {
- "ctype", "numeric", "time", "collate", "monetary",
- "all", NULL
+TestlinkarrayCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *LinkOption[] = {
+ "update", "remove", "create", NULL
};
- static const int lcTypes[] = {
- LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
- LC_ALL
+ enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
+ static const char *LinkType[] = {
+ "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
+ "wide", "uwide", "float", "double", "string", "char*", "binary", NULL
};
+ /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
+ static int LinkTypes[] = {
+ TCL_LINK_CHAR, TCL_LINK_UCHAR,
+ TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
+ TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
+ TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
+ TCL_LINK_BINARY
+ };
+ int optionIndex, typeIndex, readonly, i, size, length;
+ char *name, *arg;
+ Tcl_WideInt addr;
- /*
- * LC_CTYPE, etc. correspond to the indices for the strings.
- */
-
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
-
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
+ &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
+ switch ((enum LinkOptionEnum) optionIndex) {
+ case LINK_UPDATE:
+ for (i=2; i<objc; i++) {
+ Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_REMOVE:
+ for (i=2; i<objc; i++) {
+ Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_CREATE:
+ if (objc < 4) {
+ goto wrongArgs;
+ }
+ readonly = 0;
+ i = 2;
- if (objc == 3) {
- locale = Tcl_GetString(objv[2]);
- } else {
- locale = NULL;
- }
- locale = setlocale(lcTypes[index], locale);
- if (locale) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ /*
+ * test on switch -r...
+ */
+
+ arg = Tcl_GetStringFromObj(objv[i], &length);
+ if (length < 2) {
+ goto wrongArgs;
+ }
+ if (arg[0] == '-') {
+ if (arg[1] != 'r') {
+ goto wrongArgs;
+ }
+ readonly = TCL_LINK_READ_ONLY;
+ i++;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
+ &typeIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", TCL_INDEX_NONE));
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[i++]);
+
+ /*
+ * If no address is given request one in the underlying function
+ */
+
+ if (i < objc) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong address value", TCL_INDEX_NONE));
+ return TCL_ERROR;
+ }
+ } else {
+ addr = 0;
+ }
+ return Tcl_LinkArray(interp, name, INT2PTR(addr),
+ LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
+
+ wrongArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
+ * TestlistrepCmd --
*
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
+ * This function is invoked to generate a list object with a specific
+ * internal representation.
*
* Results:
- * A normal Tcl completion code.
+ * A standard Tcl result.
*
* Side effects:
* None.
@@ -3258,122 +3513,203 @@ TestlocaleCmd(
*/
static int
-TestMathFunc(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Not used. */
- Tcl_Value *args, /* Not used. */
- Tcl_Value *resultPtr) /* Where to store result. */
-{
- resultPtr->type = TCL_INT;
- resultPtr->intValue = PTR2INT(clientData);
+TestlistrepCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ /* Subcommands supported by this command */
+ const char* subcommands[] = {
+ "new",
+ "describe",
+ "config",
+ "validate",
+ NULL
+ };
+ enum {
+ LISTREP_NEW,
+ LISTREP_DESCRIBE,
+ LISTREP_CONFIG,
+ LISTREP_VALIDATE
+ } cmdIndex;
+ Tcl_Obj *resultObj = NULL;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case LISTREP_NEW:
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?");
+ return TCL_ERROR;
+ } else {
+ Tcl_WideUInt length;
+ Tcl_WideUInt leadSpace = 0;
+ Tcl_WideUInt endSpace = 0;
+ if (Tcl_GetWideUIntFromObj(interp, objv[2], &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetWideUIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 4) {
+ if (Tcl_GetWideUIntFromObj(interp, objv[4], &endSpace)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ resultObj = TclListTestObj(length, leadSpace, endSpace);
+ if (resultObj == NULL) {
+ Tcl_AppendResult(interp, "List capacity exceeded", NULL);
+ return TCL_ERROR;
+ }
+ }
+ break;
+
+ case LISTREP_DESCRIBE:
+#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
+ do { \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE)); \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
+ } while (0)
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **objs;
+ Tcl_Size nobjs;
+ ListRep listRep;
+ Tcl_Obj *listRepObjs[4];
+
+ /* Force list representation */
+ if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ListObjGetRep(objv[2], &listRep);
+ listRepObjs[0] = Tcl_NewStringObj("store", TCL_INDEX_NONE);
+ listRepObjs[1] = Tcl_NewListObj(12, NULL);
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
+ if (listRep.spanPtr) {
+ listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE);
+ listRepObjs[3] = Tcl_NewListObj(8, NULL);
+ Tcl_ListObjAppendElement(interp,
+ listRepObjs[3],
+ Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
+ APPEND_FIELD(
+ listRepObjs[3], listRep.spanPtr, spanLength);
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
+ }
+ resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
+ }
+#undef APPEND_FIELD
+ break;
+
+ case LISTREP_CONFIG:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewListObj(2, NULL);
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
+ break;
+
+ case LISTREP_VALIDATE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ TclListObjValidate(interp, objv[2]); /* Panics if invalid */
+ resultObj = Tcl_NewObj();
+ break;
+ }
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TestMathFunc2 --
+ * TestlocaleCmd --
*
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
+ * This procedure implements the "testlocale" command. It is used
+ * to test the effects of setting different locales in Tcl.
*
* Results:
- * A normal Tcl completion code.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
-TestMathFunc2(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Used to report errors. */
- Tcl_Value *args, /* Points to an array of two Tcl_Value structs
- * for the two arguments. */
- Tcl_Value *resultPtr) /* Where to store the result. */
+TestlocaleCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
- int result = TCL_OK;
+ int index;
+ const char *locale;
+ static const char *const optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
+ "all", NULL
+ };
+ static const int lcTypes[] = {
+ LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
+ LC_ALL
+ };
/*
- * Return the maximum of the two arguments with the correct type.
+ * LC_CTYPE, etc. correspond to the indices for the strings.
*/
- if (args[0].type == TCL_INT) {
- int i0 = args[0].intValue;
-
- if (args[1].type == TCL_INT) {
- int i1 = args[1].intValue;
-
- resultPtr->type = TCL_INT;
- resultPtr->intValue = ((i0 > i1)? i0 : i1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = i0;
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = Tcl_LongAsWide(i0);
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_DOUBLE) {
- double d0 = args[0].doubleValue;
-
- if (args[1].type == TCL_INT) {
- double d1 = args[1].intValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- double d1 = Tcl_WideAsDouble(args[1].wideValue);
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = args[0].wideValue;
-
- if (args[1].type == TCL_INT) {
- Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = Tcl_WideAsDouble(w0);
- double d1 = args[1].doubleValue;
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ return TCL_ERROR;
+ }
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w1 = args[1].wideValue;
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
+ if (objc == 3) {
+ locale = Tcl_GetString(objv[2]);
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
- result = TCL_ERROR;
+ locale = NULL;
}
- return result;
+ locale = setlocale(lcTypes[index], locale);
+ if (locale) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, TCL_INDEX_NONE);
+ }
+ return TCL_OK;
}
/*
@@ -3392,10 +3728,11 @@ TestMathFunc2(
*
*----------------------------------------------------------------------
*/
+
static void
CleanupTestSetassocdataTests(
- ClientData clientData, /* Data to be released. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ void *clientData, /* Data to be released. */
+ TCL_UNUSED(Tcl_Interp *))
{
ckfree(clientData);
}
@@ -3419,7 +3756,7 @@ CleanupTestSetassocdataTests(
static int
TestparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3475,7 +3812,7 @@ TestparserObjCmd(
static int
TestexprparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3556,7 +3893,7 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(parsePtr->numWords));
+ Tcl_NewWideIntObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
@@ -3592,16 +3929,16 @@ PrintParse(
break;
}
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(typeString, -1));
+ Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(tokenPtr->numComponents));
+ Tcl_NewWideIntObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement(NULL, objPtr,
parsePtr->commandStart ?
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
- -1) : Tcl_NewObj());
+ TCL_INDEX_NONE) : Tcl_NewObj());
}
/*
@@ -3623,7 +3960,7 @@ PrintParse(
static int
TestparsevarObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3664,7 +4001,7 @@ TestparsevarObjCmd(
static int
TestparsevarnameObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3710,6 +4047,76 @@ TestparsevarnameObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestpreferstableObjCmd --
+ *
+ * This procedure implements the "testpreferstable" command. It is
+ * used for being able to test the "package" command even when the
+ * environment variable TCL_PKG_PREFER_LATEST is set in your environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestpreferstableObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ iPtr->packagePrefer = PKG_PREFER_STABLE;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestprintObjCmd --
+ *
+ * This procedure implements the "testprint" command. It is
+ * used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_WideInt argv1 = 0;
+ size_t argv2;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
+ }
+
+ if (objc > 1) {
+ Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+ }
+ argv2 = (size_t)argv1;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
@@ -3728,7 +4135,7 @@ TestparsevarnameObjCmd(
static int
TestregexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3745,7 +4152,7 @@ TestregexpObjCmd(
"-xflags",
"--", NULL
};
- enum options {
+ enum optionsEnum {
REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
REGEXP_XFLAGS,
@@ -3770,7 +4177,7 @@ TestregexpObjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum optionsEnum) index) {
case REGEXP_INDICES:
indices = 1;
break;
@@ -3842,7 +4249,7 @@ TestregexpObjCmd(
* value 0.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
const char *varName;
const char *value;
@@ -3850,9 +4257,9 @@ TestregexpObjCmd(
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
- TclRegExpRangeUniChar(regExpr, -1, &start, &end);
+ TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -3866,7 +4273,7 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -3890,15 +4297,15 @@ TestregexpObjCmd(
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
- ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;
+ ii = ((cflags&REG_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : i;
if (indices) {
Tcl_Obj *objs[2];
- if (ii == -1) {
+ if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
- start = -1;
- end = -1;
+ start = TCL_INDEX_NONE;
+ end = TCL_INDEX_NONE;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
@@ -3913,12 +4320,12 @@ TestregexpObjCmd(
end--;
}
- objs[0] = Tcl_NewLongObj(start);
- objs[1] = Tcl_NewLongObj(end);
+ objs[0] = Tcl_NewWideIntObj(start);
+ objs[1] = Tcl_NewWideIntObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
- if (ii == -1) {
+ if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs || info.matches[ii].end <= 0) {
@@ -3938,7 +4345,7 @@ TestregexpObjCmd(
* Set the interpreter's object result to an integer object w/ value 1.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
@@ -3962,11 +4369,12 @@ TestregexpObjCmd(
static void
TestregexpXflags(
const char *string, /* The string of flags. */
- int length, /* The length of the string in bytes. */
+ size_t length, /* The length of the string in bytes. */
int *cflagsPtr, /* compile flags word */
int *eflagsPtr) /* exec flags word */
{
- int i, cflags, eflags;
+ size_t i;
+ int cflags, eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
@@ -4051,10 +4459,10 @@ TestregexpXflags(
static int
TestreturnObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
@@ -4079,7 +4487,7 @@ TestreturnObjCmd(
static int
TestsetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4093,7 +4501,7 @@ TestsetassocdataCmd(
return TCL_ERROR;
}
- buf = ckalloc(strlen(argv[2]) + 1);
+ buf = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
@@ -4106,8 +4514,7 @@ TestsetassocdataCmd(
ckfree(oldData);
}
- Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
- (ClientData) buf);
+ Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
@@ -4131,7 +4538,7 @@ TestsetassocdataCmd(
static int
TestsetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4163,10 +4570,10 @@ TestsetplatformCmd(
/*
*----------------------------------------------------------------------
*
- * TeststaticpkgCmd --
+ * TeststaticlibraryCmd --
*
- * This procedure implements the "teststaticpkg" command.
- * It is used to test the procedure Tcl_StaticPackage.
+ * This procedure implements the "teststaticlibrary" command.
+ * It is used to test the procedure Tcl_StaticLibrary.
*
* Results:
* A standard Tcl result.
@@ -4179,8 +4586,8 @@ TestsetplatformCmd(
*/
static int
-TeststaticpkgCmd(
- ClientData dummy, /* Not used. */
+TeststaticlibraryCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4198,7 +4605,7 @@ TeststaticpkgCmd(
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
- tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
+ Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1],
StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
@@ -4208,7 +4615,7 @@ StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
* being loaded. */
{
- Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -4231,7 +4638,7 @@ StaticInitProc(
static int
TesttranslatefilenameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4272,7 +4679,7 @@ TesttranslatefilenameCmd(
static int
TestupvarCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4291,7 +4698,7 @@ TestupvarCmd(
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
- return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
+ return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
@@ -4324,13 +4731,13 @@ TestupvarCmd(
static int
TestseterrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc > 6) {
- Tcl_SetResult(interp, "too many args", TCL_STATIC);
+ Tcl_AppendResult(interp, "too many args", NULL);
return TCL_ERROR;
}
switch (argc) {
@@ -4376,7 +4783,7 @@ TestseterrorcodeCmd(
static int
TestsetobjerrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4404,7 +4811,7 @@ TestsetobjerrorcodeCmd(
static int
TestfeventCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4425,7 +4832,7 @@ TestfeventCmd(
return TCL_ERROR;
}
if (interp2 != NULL) {
- code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL);
+ code = Tcl_EvalEx(interp2, argv[2], TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
@@ -4476,19 +4883,17 @@ TestfeventCmd(
static int
TestpanicCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- char *argString;
-
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
- argString = Tcl_Merge(argc-1, argv+1);
+ char *argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
ckfree(argString);
@@ -4497,7 +4902,7 @@ TestpanicCmd(
static int
TestfileCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
@@ -4579,7 +4984,7 @@ TestfileCmd(
static int
TestgetvarfullnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4653,10 +5058,10 @@ TestgetvarfullnameCmd(
static int
GetTimesObjCmd(
- ClientData unused, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The current interpreter. */
- int objc, /* Number of arguments. (not used)*/
- Tcl_Obj *const dummy[]) /* The argument objects (not used). */
+ TCL_UNUSED(int) /*cobjc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/)
{
Interp *iPtr = (Interp *) interp;
int i, n;
@@ -4665,8 +5070,6 @@ GetTimesObjCmd(
Tcl_Obj *objPtr, **objv;
const char *s;
char newString[TCL_INTEGER_SPACE];
- (void)objc;
- (void)dummy;
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
@@ -4681,10 +5084,10 @@ GetTimesObjCmd(
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
- objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
- objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
+ objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4723,15 +5126,15 @@ GetTimesObjCmd(
ckfree(objv);
/* TclGetString 100000 times */
- fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
- objPtr = Tcl_NewStringObj("12345", -1);
+ fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
+ objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
- fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
+ fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
@@ -4784,10 +5187,10 @@ GetTimesObjCmd(
timePer/100000);
/* Tcl_SetVar 100000 times */
- fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
+ fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
+ s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -4801,7 +5204,7 @@ GetTimesObjCmd(
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
+ s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -4834,10 +5237,10 @@ GetTimesObjCmd(
static int
NoopCmd(
- ClientData unused, /* Unused. */
- Tcl_Interp *interp, /* The current interpreter. */
- int argc, /* The number of arguments. */
- const char **argv) /* The argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
@@ -4861,10 +5264,10 @@ NoopCmd(
static int
NoopObjCmd(
- ClientData unused, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* The argument objects. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
@@ -4886,14 +5289,13 @@ NoopObjCmd(
static int
TeststringbytesObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -4927,13 +5329,12 @@ TeststringbytesObjCmd(
static int
TestpurebytesobjObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
- (void)dummy;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?string?");
@@ -4975,14 +5376,13 @@ TestpurebytesobjObjCmd(
static int
TestsetbytearraylengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
Tcl_Obj *obj = NULL;
- (void)dummy;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
@@ -4991,12 +5391,17 @@ TestsetbytearraylengthObjCmd(
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
- if (Tcl_IsShared(objv[1])) {
- obj = Tcl_DuplicateObj(objv[1]);
- } else {
- obj = objv[1];
+ obj = objv[1];
+ if (Tcl_IsShared(obj)) {
+ obj = Tcl_DuplicateObj(obj);
+ }
+ if (Tcl_SetByteArrayLength(obj, n) == NULL) {
+ if (obj != objv[1]) {
+ Tcl_DecrRefCount(obj);
+ }
+ Tcl_AppendResult(interp, "expected bytes", NULL);
+ return TCL_ERROR;
}
- Tcl_SetByteArrayLength(obj, n);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -5020,21 +5425,23 @@ TestsetbytearraylengthObjCmd(
static int
TestbytestringObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int n = 0;
+ size_t n = 0;
const char *p;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
- p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
+ p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &n);
+ if (p == NULL) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
@@ -5042,6 +5449,43 @@ TestbytestringObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Testutf16stringObjCmd --
+ *
+ * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj
+ * C functions which broke in Tcl 8.7 and were undetected by the
+ * existing test suite. Bug [b79df322a9]
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+Testutf16stringObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ const unsigned short *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ p = Tcl_GetUnicode(objv[1]);
+ Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
@@ -5058,7 +5502,7 @@ TestbytestringObjCmd(
static int
TestsetCmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5067,7 +5511,7 @@ TestsetCmd(
const char *value;
if (argc == 2) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], NULL, flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5075,7 +5519,7 @@ TestsetCmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5090,7 +5534,7 @@ TestsetCmd(
}
static int
Testset2Cmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5099,7 +5543,7 @@ Testset2Cmd(
const char *value;
if (argc == 3) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5107,7 +5551,7 @@ Testset2Cmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 4) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5138,9 +5582,10 @@ Testset2Cmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static int
TestsaveresultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -5172,16 +5617,17 @@ TestsaveresultCmd(
return TCL_ERROR;
}
- objPtr = NULL; /* Lint. */
+ freeCount = 0;
+ objPtr = NULL;
switch ((enum options) index) {
case RESULT_SMALL:
- Tcl_SetResult(interp, "small result", TCL_VOLATILE);
+ Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
- char *buf = ckalloc(200);
+ char *buf = (char *)ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
@@ -5191,18 +5637,17 @@ TestsaveresultCmd(
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
- objPtr = Tcl_NewStringObj("object result", -1);
+ objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE);
Tcl_SetObjResult(interp, objPtr);
break;
}
- freeCount = 0;
Tcl_SaveResult(interp, &state);
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
- result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
+ result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
}
if (discard) {
@@ -5214,11 +5659,9 @@ TestsaveresultCmd(
switch ((enum options) index) {
case RESULT_DYNAMIC: {
- int present = iPtr->freeProc == TestsaveresultFree;
- int called = freeCount;
+ int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount;
- Tcl_AppendElement(interp, called ? "called" : "notCalled");
- Tcl_AppendElement(interp, present ? "present" : "missing");
+ Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak");
break;
}
case RESULT_OBJECT:
@@ -5249,10 +5692,11 @@ TestsaveresultCmd(
static void
TestsaveresultFree(
- char *blockPtr)
+ TCL_UNUSED(char *))
{
freeCount++;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5273,10 +5717,10 @@ TestsaveresultFree(
static int
TestmainthreadCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(const char **) /*argv*/)
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
@@ -5284,7 +5728,7 @@ TestmainthreadCmd(
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
}
@@ -5334,14 +5778,14 @@ MainLoop(void)
static int
TestsetmainloopCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- exitMainLoop = 0;
- Tcl_SetMainLoop(MainLoop);
- return TCL_OK;
+ exitMainLoop = 0;
+ Tcl_SetMainLoop(MainLoop);
+ return TCL_OK;
}
/*
@@ -5363,13 +5807,13 @@ TestsetmainloopCmd(
static int
TestexitmainloopCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- exitMainLoop = 1;
- return TCL_OK;
+ exitMainLoop = 1;
+ return TCL_OK;
}
/*
@@ -5391,7 +5835,7 @@ TestexitmainloopCmd(
static int
TestChannelCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
@@ -5456,7 +5900,7 @@ TestChannelCmd(
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelError(chan, msg);
@@ -5469,7 +5913,7 @@ TestChannelCmd(
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelErrorInterp(interp, msg);
@@ -5668,6 +6112,45 @@ TestChannelCmd(
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ if (statePtr->maxPerms & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->maxPerms & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", NULL);
@@ -5817,7 +6300,7 @@ TestChannelCmd(
}
return TclChannelTransform(interp, chan,
- Tcl_NewStringObj(argv[4], -1));
+ Tcl_NewStringObj(argv[4], TCL_INDEX_NONE));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
@@ -5858,7 +6341,7 @@ TestChannelCmd(
static int
TestChannelEventCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5901,19 +6384,18 @@ TestChannelEventCmd(
return TCL_ERROR;
}
- esPtr = (EventScriptRecord *) ckalloc((unsigned)
- sizeof(EventScriptRecord));
+ esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
- esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
+ esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
@@ -5957,7 +6439,7 @@ TestChannelEventCmd(
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
@@ -5976,10 +6458,10 @@ TestChannelEventCmd(
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
+ (esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
- Tcl_NewStringObj("none", -1));
+ Tcl_NewStringObj("none", TCL_INDEX_NONE));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
@@ -5998,7 +6480,7 @@ TestChannelEventCmd(
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
}
@@ -6044,7 +6526,7 @@ TestChannelEventCmd(
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
@@ -6055,6 +6537,86 @@ TestChannelEventCmd(
/*
*----------------------------------------------------------------------
*
+ * TestSocketCmd --
+ *
+ * Implements the Tcl "testsocket" debugging command and its
+ * subcommands. This is part of the testing environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not
+ * automatically continue connection
+ * process. */
+
+static int
+TestSocketCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Interpreter for result. */
+ int argc, /* Count of additional args. */
+ const char **argv) /* Additional arg strings. */
+{
+ const char *cmdName; /* Sub command. */
+ size_t len; /* Length of subcommand string. */
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", NULL);
+ return TCL_ERROR;
+ }
+ cmdName = argv[1];
+ len = strlen(cmdName);
+
+ if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
+ Tcl_Channel hChannel;
+ int modePtr;
+ int testMode;
+ TcpState *statePtr;
+ /* Set test value in the socket driver
+ */
+ /* Check for argument "channel name"
+ */
+ if (argc < 4) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " testflags channel flags\"", NULL);
+ return TCL_ERROR;
+ }
+ hChannel = Tcl_GetChannel(interp, argv[2], &modePtr);
+ if ( NULL == hChannel ) {
+ Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL);
+ return TCL_ERROR;
+ }
+ statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
+ if ( NULL == statePtr) {
+ Tcl_AppendResult(interp, "No channel instance data:", argv[2],
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (testMode) {
+ statePtr->flags |= TCP_ASYNC_TEST_MODE;
+ } else {
+ statePtr->flags &= ~TCP_ASYNC_TEST_MODE;
+ }
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "testflags", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestServiceModeCmd --
*
* This procedure implements the "testservicemode" command which gets or
@@ -6074,7 +6636,7 @@ TestChannelEventCmd(
static int
TestServiceModeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -6096,7 +6658,7 @@ TestServiceModeCmd(
Tcl_SetServiceMode(TCL_SERVICE_ALL);
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode));
return TCL_OK;
}
@@ -6118,7 +6680,7 @@ TestServiceModeCmd(
static int
TestWrongNumArgsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6127,15 +6689,10 @@ TestWrongNumArgsObjCmd(
const char *msg;
if (objc < 3) {
- /*
- * Don't use Tcl_WrongNumArgs here, as that is the function
- * we want to test!
- */
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
- return TCL_ERROR;
+ goto insufArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -6148,7 +6705,8 @@ TestWrongNumArgsObjCmd(
/*
* Asked for more arguments than were given.
*/
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ insufArgs:
+ Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6174,7 +6732,7 @@ TestWrongNumArgsObjCmd(
static int
TestGetIndexFromObjStructObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6182,7 +6740,8 @@ TestGetIndexFromObjStructObjCmd(
const char *const ary[] = {
"a", "b", "c", "d", "ee", "ff", NULL, NULL
};
- int idx,target, flags = 0;
+ int target, flags = 0;
+ signed char idx[8];
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?");
@@ -6194,13 +6753,17 @@ TestGetIndexFromObjStructObjCmd(
if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) {
return TCL_ERROR;
}
+ memset(idx, 85, sizeof(idx));
if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *),
- "dummy", flags, &idx) != TCL_OK) {
+ "dummy", flags, &idx[1]) != TCL_OK) {
return TCL_ERROR;
}
- if (idx != target) {
+ if (idx[0] != 85 || idx[2] != 85) {
+ Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", NULL);
+ return TCL_ERROR;
+ } else if (idx[1] != target) {
char buffer[64];
- sprintf(buffer, "%d", idx);
+ sprintf(buffer, "%d", idx[1]);
Tcl_AppendResult(interp, "index value comparison failed: got ",
buffer, NULL);
sprintf(buffer, "%d", target);
@@ -6231,7 +6794,7 @@ TestGetIndexFromObjStructObjCmd(
static int
TestFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6247,20 +6810,20 @@ TestFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
+ res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
@@ -6282,7 +6845,7 @@ TestReportInFilesystem(
return -1;
}
lastPathPtr = NULL;
- *clientDataPtr = (ClientData) newPathPtr;
+ *clientDataPtr = newPathPtr;
return TCL_OK;
}
@@ -6300,7 +6863,7 @@ TestReportGetNativePath(
static void
TestReportFreeInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
@@ -6310,9 +6873,9 @@ TestReportFreeInternalRep(
}
}
-static ClientData
+static void *
TestReportDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
@@ -6335,7 +6898,7 @@ TestReport(
Tcl_DString ds;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
+ Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
@@ -6348,7 +6911,7 @@ TestReport(
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_Eval(interp, Tcl_DStringValue(&ds));
+ Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
@@ -6562,7 +7125,7 @@ TestReportUtime(
static int
TestReportNormalizePath(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
@@ -6573,7 +7136,7 @@ TestReportNormalizePath(
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(void **))
{
const char *str = Tcl_GetString(pathPtr);
@@ -6602,7 +7165,7 @@ SimplePathInFilesystem(
static int
TestSimpleFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6618,13 +7181,13 @@ TestSimpleFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
+ res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
@@ -6651,7 +7214,7 @@ SimpleRedirect(
Tcl_IncrRefCount(pathPtr);
return pathPtr;
}
- origPtr = Tcl_NewStringObj(str+10,-1);
+ origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE);
Tcl_IncrRefCount(origPtr);
return origPtr;
}
@@ -6683,7 +7246,7 @@ SimpleMatchInDirectory(
origPtr = SimpleRedirect(dirPtr);
res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types);
if (res == TCL_OK) {
- int gLength, j;
+ size_t gLength, j;
Tcl_ListObjLength(NULL, resPtr, &gLength);
for (j = 0; j < gLength; j++) {
Tcl_Obj *gElt, *nElt;
@@ -6751,7 +7314,7 @@ SimpleListVolumes(void)
/* Add one new volume */
Tcl_Obj *retVal;
- retVal = Tcl_NewStringObj("simplefs:/", -1);
+ retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE);
Tcl_IncrRefCount(retVal);
return retVal;
}
@@ -6759,65 +7322,39 @@ SimpleListVolumes(void)
/*
* Used to check operations of Tcl_UtfNext.
*
- * Usage: testutfnext $bytes $offset
+ * Usage: testutfnext -bytestring $bytes
*/
static int
TestUtfNextCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- int numBytes; /* Number of bytes supplied in the test string */
- int offset; /* Number of bytes we are permitted to read */
+ int numBytes;
char *bytes;
const char *result, *first;
char buffer[32];
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
- (void)dummy;
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "string ?numBytes?");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
+ bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
- bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
-
- offset = numBytes +TCL_UTF_MAX -1; /* If no constraint is given, allow
- * the terminating NUL to limit
- * operations. */
-
- if (objc == 3) {
- if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) {
- return TCL_ERROR;
- }
- if (offset < 0) {
- offset = 0;
- }
- if (offset > numBytes +TCL_UTF_MAX -1) {
- offset = numBytes +TCL_UTF_MAX -1;
- }
- }
-
- if (numBytes > (int)sizeof(buffer) - 3) {
+ if (numBytes + 4U > sizeof(buffer)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"testutfnext\" can only handle %d bytes",
- (int)sizeof(buffer) - 4));
+ "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes",
+ sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
- if (!Tcl_UtfCharComplete(buffer + 1, offset)) {
- /* Cannot scan a complete sequence from the data */
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- return TCL_OK;
- }
-
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
@@ -6839,7 +7376,7 @@ TestUtfNextCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1));
return TCL_OK;
}
@@ -6851,7 +7388,7 @@ TestUtfNextCmd(
static int
TestUtfPrevCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6868,7 +7405,7 @@ TestUtfPrevCmd(
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
- if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) {
+ if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset < 0) {
@@ -6880,8 +7417,8 @@ TestUtfPrevCmd(
} else {
offset = numBytes;
}
- result = TclUtfPrev(bytes + offset, bytes);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes));
+ result = Tcl_UtfPrev(bytes + offset, bytes);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes));
return TCL_OK;
}
@@ -6891,17 +7428,17 @@ TestUtfPrevCmd(
static int
TestNumUtfCharsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
- int numBytes, len, limit = -1;
+ int numBytes, len, limit = TCL_INDEX_NONE;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
- if (TclGetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
@@ -6909,7 +7446,7 @@ TestNumUtfCharsCmd(
}
}
len = Tcl_NumUtfChars(bytes, limit);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len));
}
return TCL_OK;
}
@@ -6920,7 +7457,7 @@ TestNumUtfCharsCmd(
static int
TestFindFirstCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6931,7 +7468,7 @@ TestFindFirstCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
@@ -6942,7 +7479,7 @@ TestFindFirstCmd(
static int
TestFindLastCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6953,11 +7490,38 @@ TestFindLastCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
+static int
+TestGetIntForIndexCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int result;
+ Tcl_WideInt endvalue;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "index endvalue");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &endvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
+}
+
+
+
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
/*
*----------------------------------------------------------------------
@@ -6984,13 +7548,13 @@ TestFindLastCmd(
static int
TestcpuidCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
- unsigned int regs[4];
+ int regs[4];
Tcl_Obj *regsObjs[4];
if (objc != 2) {
@@ -7000,14 +7564,14 @@ TestcpuidCmd(
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
- status = TclWinCPUID((unsigned) index, regs);
+ status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("operation not available", -1));
+ Tcl_NewStringObj("operation not available", TCL_INDEX_NONE));
return status;
}
for (i=0 ; i<4 ; ++i) {
- regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ regsObjs[i] = Tcl_NewWideIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -7020,7 +7584,7 @@ TestcpuidCmd(
static int
TestHashSystemHashCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7032,7 +7596,6 @@ TestHashSystemHashCmd(
Tcl_HashTable hash;
Tcl_HashEntry *hPtr;
int i, isNew, limit = 100;
- (void)dummy;
if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
return TCL_ERROR;
@@ -7049,8 +7612,8 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7066,14 +7629,14 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7097,15 +7660,13 @@ TestHashSystemHashCmd(
*/
static int
TestgetintCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int argc,
const char **argv)
{
- (void)dummy;
-
if (argc < 2) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
} else {
int val, i, total=0;
@@ -7116,19 +7677,36 @@ TestgetintCmd(
}
total += val;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total));
return TCL_OK;
}
}
+/*
+ * Used for determining sizeof(long) at script level.
+ */
+static int
+TestlongsizeCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int argc,
+ TCL_UNUSED(const char **) /*argv*/)
+{
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(long)));
+ return TCL_OK;
+}
+
static int
NREUnwind_callback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
int none;
- (void)result;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
@@ -7141,9 +7719,9 @@ NREUnwind_callback(
&none, NULL);
} else {
Tcl_Obj *idata[3];
- idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0]));
- idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0]));
- idata[2] = Tcl_NewIntObj((int) ((char *) &none - (char *) data[0]));
+ idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0]));
+ idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0]));
+ idata[2] = Tcl_NewWideIntObj(((char *) &none - (char *) data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
@@ -7151,15 +7729,11 @@ NREUnwind_callback(
static int
TestNREUnwind(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
- (void)dummy;
- (void)objc;
- (void)objv;
-
/*
* Insure that callbacks effectively run at the proper level during the
* unwinding of the NRE stack.
@@ -7173,10 +7747,10 @@ TestNREUnwind(
static int
TestNRELevels(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
@@ -7184,9 +7758,6 @@ TestNRELevels(
Tcl_Obj *levels[6];
int i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
- (void)dummy;
- (void)objc;
- (void)objv;
if (refDepth == NULL) {
refDepth = &depth;
@@ -7194,18 +7765,18 @@ TestNRELevels(
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
+ levels[0] = Tcl_NewWideIntObj(depth);
+ levels[1] = Tcl_NewWideIntObj(iPtr->numLevels);
+ levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
- iPtr->execEnvPtr->execStackPtr->stackWords);
while (cbPtr) {
i++;
cbPtr = cbPtr->nextPtr;
}
- levels[5] = Tcl_NewIntObj(i);
+ levels[5] = Tcl_NewWideIntObj(i);
Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
return TCL_OK;
@@ -7232,13 +7803,14 @@ TestNRELevels(
static int
TestconcatobjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
- int result = TCL_OK, len;
+ int result = TCL_OK;
+ size_t len;
Tcl_Obj *objv[3];
/*
@@ -7247,23 +7819,17 @@ TestconcatobjCmd(
*/
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
+ Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE));
emptyPtr = Tcl_NewObj();
- list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
+ list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list1Ptr, &len);
- if (list1Ptr->bytes != NULL) {
- ckfree(list1Ptr->bytes);
- list1Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list1Ptr);
- list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
+ list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list2Ptr, &len);
- if (list2Ptr->bytes != NULL) {
- ckfree(list2Ptr->bytes);
- list2Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
@@ -7512,6 +8078,72 @@ TestconcatobjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestgetencpathObjCmd --
+ *
+ * This function implements the "testgetencpath" command. It is used to
+ * test Tcl_GetEncodingSearchPath().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestgetencpathObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument strings. */
+{
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsetencpathCmd --
+ *
+ * This function implements the "testsetencpath" command. It is used to
+ * test Tcl_SetDefaultEncodingDir().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetencpathObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument strings. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "defaultDir");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetEncodingSearchPath(objv[1]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
@@ -7529,13 +8161,13 @@ TestconcatobjCmd(
static int
TestparseargsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
static int foo = 0;
- int count = objc;
+ size_t count = objc;
Tcl_Obj **remObjv, *result[3];
Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
@@ -7546,8 +8178,8 @@ TestparseargsCmd(
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
- result[0] = Tcl_NewIntObj(foo);
- result[1] = Tcl_NewIntObj(count);
+ result[0] = Tcl_NewWideIntObj(foo);
+ result[1] = Tcl_NewWideIntObj(count);
result[2] = Tcl_NewListObj(count, remObjv);
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
ckfree(remObjv);
@@ -7562,8 +8194,8 @@ static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
- Tcl_Namespace *dummy,
- int flags,
+ TCL_UNUSED(Tcl_Namespace *),
+ TCL_UNUSED(int) /*flags*/,
Tcl_Command *rPtr)
{
Interp *iPtr = (Interp *) interp;
@@ -7572,7 +8204,6 @@ InterpCmdResolver(
varFramePtr->procPtr : NULL;
Namespace *callerNsPtr = varFramePtr->nsPtr;
Tcl_Command resolvedCmdPtr = NULL;
- (void)dummy;
/*
* Just do something special on a cmd literal "z" in two cases:
@@ -7632,7 +8263,7 @@ InterpCmdResolver(
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
- char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
+ const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
@@ -7654,11 +8285,11 @@ InterpCmdResolver(
static int
InterpVarResolver(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *context,
- int flags,
- Tcl_Var *rPtr)
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(Tcl_Namespace *),
+ TCL_UNUSED(int),
+ TCL_UNUSED(Tcl_Var *))
{
/*
* Don't resolve the variable; use standard rules.
@@ -7698,7 +8329,7 @@ MyCompiledVarFree(
}
#define TclVarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
@@ -7747,19 +8378,19 @@ MyCompiledVarFetch(
static int
InterpCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *name,
- int length,
- Tcl_Namespace *context,
+ TCL_UNUSED(int) /*length*/,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
- MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(sizeof(MyResolvedVarInfo));
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
- resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
@@ -7769,7 +8400,7 @@ InterpCompiledVarResolver(
static int
TestInterpResolverCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7831,10 +8462,10 @@ TestInterpResolverCmd(
*------------------------------------------------------------------------
*/
int TestApplyLambdaObjCmd (
- ClientData notUsed,
+ TCL_UNUSED(void*),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ TCL_UNUSED(int), /* objc. */
+ TCL_UNUSED(Tcl_Obj *const *)) /* objv. */
{
Tcl_Obj *lambdaObjs[2];
Tcl_Obj *evalObjs[2];
@@ -7843,12 +8474,12 @@ int TestApplyLambdaObjCmd (
/* Create a lambda {{} {set a 42}} */
lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
- lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
+ lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */
lambdaObj = Tcl_NewListObj(2, lambdaObjs);
Tcl_IncrRefCount(lambdaObj);
/* Create the command "apply {{} {set a 42}" */
- evalObjs[0] = Tcl_NewStringObj("apply", -1);
+ evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE);
Tcl_IncrRefCount(evalObjs[0]);
/*
* NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index b1a0afa..c9a910a 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -6,59 +6,61 @@
* These commands are not normally included in Tcl applications; they're
* only used for testing.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
+ * Copyright © 2005 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.
*/
-
+#undef BUILD_tcl
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
-#include "tommath.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
#include "tclStringRep.h"
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
/*
* Forward declarations for functions defined later in this file:
*/
-static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex);
+static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, size_t varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
- const char *string, int *indexPtr);
-static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr);
-static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestbooleanobjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Obj *obj, size_t *indexPtr);
+static void SetVarToObj(Tcl_Obj **varPtr, size_t varIndex, Tcl_Obj *objPtr);
+static Tcl_ObjCmdProc TestbignumobjCmd;
+static Tcl_ObjCmdProc TestbooleanobjCmd;
+static Tcl_ObjCmdProc TestdoubleobjCmd;
+static Tcl_ObjCmdProc TestindexobjCmd;
+static Tcl_ObjCmdProc TestintobjCmd;
+static Tcl_ObjCmdProc TestlistobjCmd;
+static Tcl_ObjCmdProc TestobjCmd;
+static Tcl_ObjCmdProc TeststringobjCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
-static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp)
+static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *))
{
int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
}
- Tcl_DeleteAssocData(interp, VARPTR_KEY);
ckfree(varPtr);
}
@@ -146,7 +148,7 @@ TclObjTest_Init(
static int
TestbignumobjCmd(
- ClientData clientData, /* unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
@@ -158,7 +160,8 @@ TestbignumobjCmd(
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
BIGNUM_RADIXSIZE
};
- int index, varIndex;
+ int index;
+ size_t varIndex;
const char *string;
mp_int bignumValue;
Tcl_Obj **varPtr;
@@ -171,13 +174,12 @@ TestbignumobjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- string = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
- switch (index) {
+ switch ((enum options)index) {
case BIGNUM_SET:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "var value");
@@ -290,9 +292,9 @@ TestbignumobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue));
+ Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue)));
+ SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue)));
}
mp_clear(&bignumValue);
break;
@@ -313,9 +315,9 @@ TestbignumobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], index);
+ Tcl_SetWideIntObj(varPtr[varIndex], index);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(index));
}
mp_clear(&bignumValue);
break;
@@ -345,13 +347,14 @@ TestbignumobjCmd(
static int
TestbooleanobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex, boolValue;
- const char *index, *subCmd;
+ size_t varIndex;
+ int boolValue;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -360,8 +363,7 @@ TestbooleanobjCmd(
return TCL_ERROR;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -445,14 +447,14 @@ TestbooleanobjCmd(
static int
TestdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex;
+ size_t varIndex;
double doubleValue;
- const char *index, *subCmd, *string;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -463,8 +465,7 @@ TestdoubleobjCmd(
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -473,8 +474,7 @@ TestdoubleobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
+ if (Tcl_GetDouble(interp, Tcl_GetString(objv[3]), &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
@@ -563,23 +563,24 @@ TestdoubleobjCmd(
static int
TestindexobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int allowAbbrev, index, index2, setError, i, result;
+ int allowAbbrev, index, setError, i, result;
+ Tcl_WideInt index2;
const char **argv;
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. */
- };
- struct IndexRep *indexRep;
+ TCL_HASH_TYPE offset; /* Offset between table entries. */
+ TCL_HASH_TYPE index; /* Selected index into table. */
+ } *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
@@ -589,17 +590,17 @@ TestindexobjCmd(
* lookups.
*/
- if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
+ indexRep = (struct IndexRep *)objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -616,32 +617,18 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = ckalloc((objc-3) * sizeof(char *));
+ argv = (const char **)ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
- /*
- * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
- * that its address is different for each index object. If we accidently
- * allocate a table at the same address as that cached in the index
- * object, clear out the object's cached state.
- */
-
- if (objv[3]->typePtr != NULL
- && !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
- if (indexRep->tablePtr == (void *) argv) {
- TclFreeIntRep(objv[3]);
- }
- }
-
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
- argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
+ argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
+ &index);
ckfree(argv);
if (result == TCL_OK) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -666,14 +653,17 @@ TestindexobjCmd(
static int
TestintobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int intValue, varIndex, i;
- long longValue;
- const char *index, *subCmd, *string;
+ size_t varIndex;
+#if (INT_MAX != LONG_MAX) /* int is not the same size as long */
+ int i;
+#endif
+ Tcl_WideInt wideValue;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -683,8 +673,7 @@ TestintobjCmd(
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -693,11 +682,9 @@ TestintobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
/*
* If the object currently bound to the variable with index varIndex
@@ -708,62 +695,58 @@ TestintobjCmd(
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
- } else if (strcmp(subCmd, "setlong") == 0) {
+ } else if (strcmp(subCmd, "setint") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "setmaxlong") == 0) {
- long maxLong = LONG_MAX;
+ } else if (strcmp(subCmd, "setmax") == 0) {
+ Tcl_WideInt maxWide = WIDE_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], maxLong);
+ Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
}
- } else if (strcmp(subCmd, "ismaxlong") == 0) {
+ } else if (strcmp(subCmd, "ismax") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ((longValue == LONG_MAX)? "1" : "0"), -1);
+ ((wideValue == WIDE_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -779,8 +762,7 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetString(varPtr[varIndex]);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
@@ -796,9 +778,9 @@ TestintobjCmd(
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
+ Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
@@ -814,14 +796,14 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
+ &wideValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue * 10);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
@@ -831,14 +813,14 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
+ &wideValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue / 10);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
@@ -859,6 +841,35 @@ TestintobjCmd(
* test a few possible corner cases in list object manipulation from
* C code that cannot occur at the Tcl level.
*
+ * Following new commands are added for 8.7 as regression tests for
+ * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal
+ * representations for lists. It has to be ensured that corresponding
+ * implementations obey the invariants of the C list API. The script
+ * level tests do not suffice as Tcl list commands do not execute
+ * the same exact code path as the exported C API.
+ *
+ * Note these new commands are only useful when Tcl is compiled with
+ * TCL_MEM_DEBUG defined.
+ *
+ * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This
+ * is to test that abstract lists returning elements do not depend
+ * on caller to free them. The test case should check allocated counts
+ * with the following sequence:
+ * set before <get memory counts>
+ * testobj set VARINDEX [list a b c] (or lseq etc.)
+ * testlistobj indexnoop VARINDEX
+ * testobj unset VARINDEX
+ * set after <get memory counts>
+ * after calling this command AND freeing the passed list. The targeted
+ * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference
+ * resulting in a memory leak. Conversely, the command also checks
+ * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference
+ * count since it is supposed to have at least one reference held
+ * by the list implementation. Returns a message in interp otherwise.
+ *
+ * getelementsmemcheck - as above but for Tcl_ListObjGetElements
+
+ *
* Results:
* A standard Tcl object result.
*
@@ -870,37 +881,40 @@ TestintobjCmd(
static int
TestlistobjCmd(
- ClientData clientData, /* Not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
- const char* subcommands[] = {
+ const char* const subcommands[] = {
"set",
"get",
- "replace"
+ "replace",
+ "indexmemcheck",
+ "getelementsmemcheck",
+ NULL
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
- LISTOBJ_REPLACE
- };
-
- const char* index; /* Argument giving the variable number */
- int varIndex; /* Variable number converted to binary */
- int cmdIndex; /* Ordinal number of the subcommand */
- int first; /* First index in the list */
- int count; /* Count of elements in a list */
+ LISTOBJ_REPLACE,
+ LISTOBJ_INDEXMEMCHECK,
+ LISTOBJ_GETELEMENTSMEMCHECK,
+ } cmdIndex;
+
+ size_t varIndex; /* Variable number converted to binary */
+ Tcl_WideInt first; /* First index in the list */
+ Tcl_WideInt count; /* Count of elements in a list */
Tcl_Obj **varPtr;
+ int i, len;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
@@ -934,8 +948,8 @@ TestlistobjCmd(
"varIndex start count ?element...?");
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &first) != TCL_OK
+ || Tcl_GetWideIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
@@ -944,6 +958,56 @@ TestlistobjCmd(
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
+
+ case LISTOBJ_INDEXMEMCHECK:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < len; ++i) {
+ Tcl_Obj *objP;
+ if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objP->refCount <= 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Tcl_ListObjIndex returned object with ref count <= 0",
+ TCL_INDEX_NONE));
+ /* Keep looping since we are also looping for leaks */
+ }
+ }
+ break;
+
+ case LISTOBJ_GETELEMENTSMEMCHECK:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **elems;
+ if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < len; ++i) {
+ if (elems[i]->refCount <= 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Tcl_ListObjGetElements element has ref count <= 0",
+ TCL_INDEX_NONE));
+ break;
+ }
+ }
+ }
+ break;
}
return TCL_OK;
}
@@ -967,15 +1031,28 @@ TestlistobjCmd(
static int
TestobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex, destIndex, i;
- const char *index, *subCmd, *string;
+ size_t varIndex, destIndex;
+ int i;
const Tcl_ObjType *targetType;
Tcl_Obj **varPtr;
+ const char *subcommands[] = {
+ "freeallvars", "bug3598580", "types",
+ "objtype", "newobj", "set",
+ "assign", "convert", "duplicate",
+ "invalidateStringRep", "refcount", "type",
+ NULL
+ };
+ enum testobjCmdIndex {
+ TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES,
+ TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET,
+ TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE,
+ TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE,
+ } cmdIndex;
if (objc < 2) {
wrongNumArgs:
@@ -984,170 +1061,175 @@ TestobjCmd(
}
varPtr = GetVarPtr(interp);
- subCmd = Tcl_GetString(objv[1]);
- if (strcmp(subCmd, "assign") == 0) {
- if (objc != 4) {
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case TESTOBJ_FREEALLVARS:
+ if (objc != 2) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
+ for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
+ if (varPtr[i] != NULL) {
+ Tcl_DecrRefCount(varPtr[i]);
+ varPtr[i] = NULL;
+ }
}
- string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_OK;
+ case TESTOBJ_BUG3598580:
+ if (objc != 2) {
+ goto wrongNumArgs;
+ } else {
+ Tcl_Obj *listObjPtr, *elemObjPtr;
+ elemObjPtr = Tcl_NewWideIntObj(123);
+ listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
+ /* Replace the single list element through itself, nonsense but
+ * legal. */
+ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
+ Tcl_SetObjResult(interp, listObjPtr);
}
- SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
- Tcl_SetObjResult(interp, varPtr[destIndex]);
- } else if (strcmp(subCmd, "bug3598580") == 0) {
- Tcl_Obj *listObjPtr, *elemObjPtr;
+ return TCL_OK;
+ case TESTOBJ_TYPES:
if (objc != 2) {
goto wrongNumArgs;
+ } else {
+ Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL);
+ Tcl_AppendAllObjTypes(interp, typesObj);
+ Tcl_SetObjResult(interp, typesObj);
}
- elemObjPtr = Tcl_NewIntObj(123);
- listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
- /* Replace the single list element through itself, nonsense but legal. */
- Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
- Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
- } else if (strcmp(subCmd, "convert") == 0) {
- const char *typeName;
+ case TESTOBJ_OBJTYPE:
+ /*
+ * Return an object containing the name of the argument's type of
+ * internal rep. If none exists, return "none".
+ */
- if (objc != 4) {
+ if (objc != 3) {
goto wrongNumArgs;
+ } else {
+ const char *typeName;
+
+ if (objv[2]->typePtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
+ }
+ else {
+ typeName = objv[2]->typePtr->name;
+ if (!strcmp(typeName, "utf32string"))
+ typeName = "string";
+#ifndef TCL_WIDE_INT_IS_LONG
+ else if (!strcmp(typeName, "wideInt")) typeName = "int";
+#endif
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
+ }
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,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;
+ return TCL_OK;
+ case TESTOBJ_NEWOBJ:
+ if (objc != 3) {
+ goto wrongNumArgs;
}
- if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
- != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
+ SetVarToObj(varPtr, varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "duplicate") == 0) {
+ return TCL_OK;
+ case TESTOBJ_SET:
if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
+ SetVarToObj(varPtr, varIndex, objv[3]);
+ return TCL_OK;
+
+ default:
+ break;
+ }
+
+ /* All further commands expect an occupied varindex argument */
+ if (objc < 3) {
+ goto wrongNumArgs;
+ }
+
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ }
+
+ switch (cmdIndex) {
+ case TESTOBJ_ASSIGN:
+ if (objc != 4) {
+ goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varPtr, destIndex, 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) {
+ break;
+ case TESTOBJ_CONVERT:
+ if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "no type ", Tcl_GetString(objv[3]), " found", NULL);
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
+ != TCL_OK) {
return TCL_ERROR;
}
- Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "newobj") == 0) {
- if (objc != 3) {
+ break;
+ case TESTOBJ_DUPLICATE:
+ if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, 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".
- */
-
+ SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ Tcl_SetObjResult(interp, varPtr[destIndex]);
+ break;
+ case TESTOBJ_INVALIDATESTRINGREP:
if (objc != 3) {
goto wrongNumArgs;
}
- if (objv[2]->typePtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
- } else {
- typeName = objv[2]->typePtr->name;
- Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
- }
- } else if (strcmp(subCmd, "refcount") == 0) {
+ Tcl_InvalidateStringRep(varPtr[varIndex]);
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ break;
+ case TESTOBJ_REFCOUNT:
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
- } else if (strcmp(subCmd, "type") == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
+ break;
+ case TESTOBJ_TYPE:
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "int", -1);
+#endif
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
- } else if (strcmp(subCmd, "types") == 0) {
- if (objc != 2) {
- goto wrongNumArgs;
- }
- if (Tcl_AppendAllObjTypes(interp,
- Tcl_GetObjResult(interp)) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetString(objv[1]),
- "\": must be assign, convert, duplicate, freeallvars, "
- "newobj, objcount, objtype, refcount, type, or types", NULL);
- return TCL_ERROR;
+ break;
+ default:
+ break;
}
+
return TCL_OK;
}
@@ -1171,21 +1253,23 @@ TestobjCmd(
static int
TeststringobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *unicode;
- int varIndex, option, i, length;
+ unsigned short *unicode;
+ size_t varIndex;
+ int size, option, i;
+ Tcl_WideInt length;
#define MAX_STRINGS 11
- const char *index, *string, *strings[MAX_STRINGS+1];
+ const char *string, *strings[MAX_STRINGS+1];
String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
- "set", "set2", "setlength", "maxchars", "range", "getunicode",
- "appendself", "appendself2", NULL
+ "set", "set2", "setlength", "maxchars", "range", "appendself",
+ "appendself2", NULL
};
if (objc < 3) {
@@ -1195,8 +1279,7 @@ TeststringobjCmd(
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -1209,7 +1292,7 @@ TeststringobjCmd(
if (objc != 5) {
goto wrongNumArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
@@ -1224,8 +1307,7 @@ TeststringobjCmd(
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetString(objv[3]);
- Tcl_AppendToObj(varPtr[varIndex], string, length);
+ Tcl_AppendToObj(varPtr[varIndex], Tcl_GetString(objv[3]), length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
@@ -1272,14 +1354,13 @@ TeststringobjCmd(
if (CheckIfVarUnset(interp, varPtr, varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetString(varPtr[varIndex]);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
@@ -1287,14 +1368,18 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = (int) strPtr->allocated;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex], objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = (int) strPtr->allocated;
+ } else {
+ length = -1;
+ }
} else {
length = -1;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
@@ -1310,12 +1395,12 @@ TeststringobjCmd(
* is "copy on write".
*/
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetStringFromObj(objv[3], &size);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetStringObj(varPtr[varIndex], string, length);
+ Tcl_SetStringObj(varPtr[varIndex], string, size);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length));
+ SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
@@ -1329,7 +1414,7 @@ TeststringobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
@@ -1341,14 +1426,18 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = strPtr->maxChars;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex],objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = strPtr->maxChars;
+ } else {
+ length = -1;
+ }
} else {
length = -1;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: { /* range */
int first, last;
@@ -1362,13 +1451,7 @@ TeststringobjCmd(
Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last));
break;
}
- case 11: /* getunicode */
- if (objc != 3) {
- goto wrongNumArgs;
- }
- Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
- break;
- case 12: /* appendself */
+ case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1385,21 +1468,21 @@ TeststringobjCmd(
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
+ string = Tcl_GetStringFromObj(varPtr[varIndex], &size);
- if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
- if ((i < 0) || (i > length)) {
+ if ((length < 0) || (length > size)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
+ Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 13: /* appendself2 */
+ case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1416,18 +1499,18 @@ TeststringobjCmd(
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
+ unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size);
- if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
- if ((i < 0) || (i > length)) {
+ if ((length < 0) || (length > size)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
+ Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
@@ -1457,7 +1540,7 @@ TeststringobjCmd(
static void
SetVarToObj(
Tcl_Obj **varPtr,
- int varIndex, /* Designates the assignment variable. */
+ size_t varIndex, /* Designates the assignment variable. */
Tcl_Obj *objPtr) /* Points to object to assign to var. */
{
if (varPtr[varIndex] != NULL) {
@@ -1488,14 +1571,14 @@ SetVarToObj(
static int
GetVariableIndex(
Tcl_Interp *interp, /* Interpreter for error reporting. */
- const char *string, /* String containing a variable index
+ Tcl_Obj *obj, /* The variable index
* specified as a nonnegative number less than
* NUMBER_OF_OBJECT_VARS. */
- int *indexPtr) /* Place to store converted result. */
+ size_t *indexPtr) /* Place to store converted result. */
{
- int index;
+ Tcl_WideInt index;
- if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, obj, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
@@ -1530,12 +1613,12 @@ static int
CheckIfVarUnset(
Tcl_Interp *interp, /* Interpreter for error reporting. */
Tcl_Obj ** varPtr,
- int varIndex) /* Index of the test variable to check. */
+ size_t varIndex) /* Index of the test variable to check. */
{
if (varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
- sprintf(buf, "variable %d is unset (NULL)", varIndex);
+ sprintf(buf, "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return 1;
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index fba2844..9b6aa1d 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -5,7 +5,7 @@
* creation of Tcl procedures whose body argument is a Tcl_Obj of type
* "procbody" rather than a string.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -20,7 +20,7 @@
* name and version of this package
*/
-static const char packageName[] = "procbodytest";
+static const char packageName[] = "tcl::procbodytest";
static const char packageVersion[] = "1.1";
/*
@@ -45,13 +45,11 @@ typedef struct CmdTable {
* Declarations for functions defined in this file.
*/
-static int ProcBodyTestProcObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int ProcBodyTestCheckObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ProcBodyTestProcObjCmd;
+static Tcl_ObjCmdProc ProcBodyTestCheckObjCmd;
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
- const char *namespace, const CmdTable *cmdTablePtr);
+ const char *namesp, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
@@ -75,7 +73,7 @@ static const CmdTable safeCommands[] = {
*
* Procbodytest_Init --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "tcl::procbodytest" package.
*
* Results:
* A standard Tcl result.
@@ -99,7 +97,7 @@ Procbodytest_Init(
*
* Procbodytest_SafeInit --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "tcl::procbodytest" package.
*
* Results:
* A standard Tcl result.
@@ -139,7 +137,7 @@ static int
RegisterCommand(
Tcl_Interp* interp, /* the Tcl interpreter for which the operation
* is performed */
- const char *namespace, /* the namespace in which the command is
+ const char *namesp, /* the namespace in which the command is
* registered */
const CmdTable *cmdTablePtr)/* the command to register */
{
@@ -147,13 +145,13 @@ RegisterCommand(
if (cmdTablePtr->exportIt) {
sprintf(buf, "namespace eval %s { namespace export %s }",
- namespace, cmdTablePtr->cmdName);
+ namesp, cmdTablePtr->cmdName);
if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
}
- sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
+ sprintf(buf, "%s::%s", namesp, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
return TCL_OK;
}
@@ -228,7 +226,7 @@ ProcBodyTestInitInternal(
static int
ProcBodyTestProcObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
@@ -315,7 +313,7 @@ ProcBodyTestProcObjCmd(
* procbodytest::check
*
* Performs an internal check that the Tcl_PkgPresent() command returns
- * the same version number as was registered when the procbodytest package
+ * the same version number as was registered when the tcl::procbodytest package
* was provided. Places a boolean in the interp result indicating the
* test outcome.
*
@@ -327,7 +325,7 @@ ProcBodyTestProcObjCmd(
static int
ProcBodyTestCheckObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 03937de..de9fac9 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -4,8 +4,8 @@
* This file implements Platform independent thread operations. Most of
* the real work is done in the platform dependent files.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 2008 by George Peter Staplin
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 2008 George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -41,21 +41,6 @@ static void RememberSyncObject(void *objPtr,
SyncObjRecord *recPtr);
/*
- * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
- * specified. Here we undo that so the functions are defined in the stubs
- * table.
- */
-
-#ifndef TCL_THREADS
-#undef Tcl_MutexLock
-#undef Tcl_MutexUnlock
-#undef Tcl_MutexFinalize
-#undef Tcl_ConditionNotify
-#undef Tcl_ConditionWait
-#undef Tcl_ConditionFinalize
-#endif
-
-/*
*----------------------------------------------------------------------
*
* Tcl_GetThreadData --
@@ -79,7 +64,7 @@ Tcl_GetThreadData(
int size) /* Size of storage block */
{
void *result;
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Initialize the key for this thread.
*/
@@ -95,7 +80,7 @@ Tcl_GetThreadData(
if (*keyPtr == NULL) {
result = ckalloc(size);
memset(result, 0, size);
- *keyPtr = result;
+ *keyPtr = (Tcl_ThreadDataKey)result;
RememberSyncObject(keyPtr, &keyRecord);
} else {
result = *keyPtr;
@@ -126,7 +111,7 @@ TclThreadDataKeyGet(
Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
return TclThreadStorageKeyGet(keyPtr);
#else /* TCL_THREADS */
return *keyPtr;
@@ -179,7 +164,7 @@ RememberSyncObject(
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
- newList = ckalloc(recPtr->max * sizeof(void *));
+ newList = (void **)ckalloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
@@ -269,11 +254,12 @@ TclRememberMutex(
*----------------------------------------------------------------------
*/
+#undef Tcl_MutexFinalize
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpGlobalLock();
@@ -322,11 +308,12 @@ TclRememberCondition(
*----------------------------------------------------------------------
*/
+#undef Tcl_ConditionFinalize
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpGlobalLock();
@@ -356,13 +343,15 @@ void
TclFinalizeThreadData(int quick)
{
TclFinalizeThreadDataThread();
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
+#else
+ (void)quick;
#endif
}
@@ -389,7 +378,7 @@ TclFinalizeSynchronization(void)
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
@@ -413,7 +402,7 @@ TclFinalizeSynchronization(void)
keyRecord.max = 0;
keyRecord.num = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Call thread storage global cleanup.
*/
@@ -473,12 +462,10 @@ Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
-#ifdef TCL_THREADS
TclpThreadExit(status);
-#endif
}
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/*
*----------------------------------------------------------------------
@@ -501,30 +488,30 @@ Tcl_ExitThread(
#undef Tcl_ConditionWait
void
Tcl_ConditionWait(
- Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */
- Tcl_Mutex *mutexPtr, /* Really (pthread_mutex_t **) */
- const Tcl_Time *timePtr) /* Timeout on waiting period */
+ TCL_UNUSED(Tcl_Condition *), /* Really (pthread_cond_t **) */
+ TCL_UNUSED(Tcl_Mutex *), /* Really (pthread_mutex_t **) */
+ TCL_UNUSED(const Tcl_Time *)) /* Timeout on waiting period */
{
}
#undef Tcl_ConditionNotify
void
Tcl_ConditionNotify(
- Tcl_Condition *condPtr)
+ TCL_UNUSED(Tcl_Condition *))
{
}
#undef Tcl_MutexLock
void
Tcl_MutexLock(
- Tcl_Mutex *mutexPtr)
+ TCL_UNUSED(Tcl_Mutex *))
{
}
#undef Tcl_MutexUnlock
void
Tcl_MutexUnlock(
- Tcl_Mutex *mutexPtr)
+ TCL_UNUSED(Tcl_Mutex *))
{
}
#endif /* !TCL_THREADS */
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 5a1e8ca..727f061 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -6,14 +6,14 @@
* fixed size blocks from block caches.
*
* The Initial Developer of the Original Code is America Online, Inc.
- * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
+ * Portions created by AOL are Copyright © 1999 America Online, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* If range checking is enabled, an additional byte will be allocated to store
@@ -82,18 +82,17 @@ typedef union Block {
* and statistics information.
*/
-typedef struct Bucket {
+typedef struct {
Block *firstPtr; /* First block available */
Block *lastPtr; /* End of block list */
- long numFree; /* Number of blocks available */
+ size_t numFree; /* Number of blocks available */
/* All fields below for accounting only */
- long numRemoves; /* Number of removes from bucket */
- long numInserts; /* Number of inserts into bucket */
- long numWaits; /* Number of waits to acquire a lock */
- long numLocks; /* Number of locks acquired */
- long totalAssigned; /* Total space assigned to bucket */
+ size_t numRemoves; /* Number of removes from bucket */
+ size_t numInserts; /* Number of inserts into bucket */
+ size_t numLocks; /* Number of locks acquired */
+ size_t totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
@@ -107,9 +106,9 @@ typedef struct Cache {
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 */
+ size_t numObjects; /* Number of objects for thread */
Tcl_Obj *lastPtr; /* Last object in this cache */
- int totalAssigned; /* Total space assigned to thread */
+ size_t totalAssigned; /* Total space assigned to thread */
Bucket buckets[NBUCKETS]; /* The buckets for this thread */
} Cache;
@@ -120,8 +119,8 @@ typedef struct Cache {
static struct {
size_t blockSize; /* Bucket blocksize. */
- int maxBlocks; /* Max blocks before move to share. */
- int numMove; /* Num blocks to move to share. */
+ size_t maxBlocks; /* Max blocks before move to share. */
+ size_t numMove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS];
@@ -132,12 +131,12 @@ static struct {
static Cache * GetCache(void);
static void LockBucket(Cache *cachePtr, int bucket);
static void UnlockBucket(Cache *cachePtr, int bucket);
-static void PutBlocks(Cache *cachePtr, int bucket, int numMove);
+static void PutBlocks(Cache *cachePtr, int bucket, size_t numMove);
static int GetBlocks(Cache *cachePtr, int bucket);
-static Block * Ptr2Block(char *ptr);
-static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
-static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);
-static void PutObjs(Cache *fromPtr, int numMove);
+static Block * Ptr2Block(void *ptr);
+static void * Block2Ptr(Block *blockPtr, int bucket, size_t reqSize);
+static void MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove);
+static void PutObjs(Cache *fromPtr, size_t numMove);
/*
* Local variables defined in this file and initialized at startup.
@@ -162,7 +161,7 @@ static __thread Cache *tcachePtr;
#else
# define GETCACHE(cachePtr) \
do { \
- (cachePtr) = TclpGetAllocCache(); \
+ (cachePtr) = (Cache*)TclpGetAllocCache(); \
if ((cachePtr) == NULL) { \
(cachePtr) = GetCache(); \
} \
@@ -196,20 +195,11 @@ GetCache(void)
if (listLockPtr == NULL) {
Tcl_Mutex *initLockPtr;
- unsigned int i;
initLockPtr = Tcl_GetAllocMutex();
Tcl_MutexLock(initLockPtr);
if (listLockPtr == NULL) {
- listLockPtr = TclpNewAllocMutex();
- objLockPtr = TclpNewAllocMutex();
- for (i = 0; i < NBUCKETS; ++i) {
- bucketInfo[i].blockSize = MINALLOC << i;
- bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
- bucketInfo[i].numMove = i < NBUCKETS - 1 ?
- 1 << (NBUCKETS - 2 - i) : 1;
- bucketInfo[i].lockPtr = TclpNewAllocMutex();
- }
+ TclInitThreadAlloc();
}
Tcl_MutexUnlock(initLockPtr);
}
@@ -218,9 +208,9 @@ GetCache(void)
* Get this thread's cache, allocating if necessary.
*/
- cachePtr = TclpGetAllocCache();
+ cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
- cachePtr = TclpSysAlloc(sizeof(Cache), 0);
+ cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0);
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
@@ -255,7 +245,7 @@ void
TclFreeAllocCache(
void *arg)
{
- Cache *cachePtr = arg;
+ Cache *cachePtr = (Cache*)arg;
Cache **nextPtrPtr;
unsigned int bucket;
@@ -308,7 +298,7 @@ TclFreeAllocCache(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int reqSize)
{
@@ -346,7 +336,7 @@ TclpAlloc(
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
- blockPtr = TclpSysAlloc(size, 0);
+ blockPtr = (Block *)TclpSysAlloc(size, 0);
if (blockPtr != NULL) {
cachePtr->totalAssigned += reqSize;
}
@@ -387,7 +377,7 @@ TclpAlloc(
void
TclpFree(
- char *ptr)
+ void *ptr)
{
Cache *cachePtr;
Block *blockPtr;
@@ -444,9 +434,9 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *ptr,
+ void *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
@@ -500,7 +490,7 @@ TclpRealloc(
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
- blockPtr = TclpSysRealloc(blockPtr, size);
+ blockPtr = (Block*)TclpSysRealloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
@@ -557,7 +547,7 @@ TclThreadAllocObj(void)
*/
if (cachePtr->numObjects == 0) {
- int numMove;
+ size_t numMove;
Tcl_MutexLock(objLockPtr);
numMove = sharedPtr->numObjects;
@@ -572,13 +562,13 @@ TclThreadAllocObj(void)
Tcl_Obj *newObjsPtr;
cachePtr->numObjects = numMove = NOBJALLOC;
- newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
+ newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
if (newObjsPtr == NULL) {
- Tcl_Panic("alloc: could not allocate %d new objects", numMove);
+ Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove);
}
cachePtr->lastPtr = newObjsPtr + numMove - 1;
objPtr = cachePtr->firstObjPtr; /* NULL */
- while (--numMove >= 0) {
+ while (numMove-- > 0) {
newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr;
objPtr = newObjsPtr + numMove;
}
@@ -591,7 +581,7 @@ TclThreadAllocObj(void)
*/
objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
@@ -680,14 +670,14 @@ Tcl_GetMemoryInfo(
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
- sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
- (unsigned long) bucketInfo[n].blockSize,
+ sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %"
+ TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u",
+ bucketInfo[n].blockSize,
cachePtr->buckets[n].numFree,
cachePtr->buckets[n].numRemoves,
cachePtr->buckets[n].numInserts,
cachePtr->buckets[n].totalAssigned,
- cachePtr->buckets[n].numLocks,
- cachePtr->buckets[n].numWaits);
+ cachePtr->buckets[n].numLocks);
Tcl_DStringAppendElement(dsPtr, buf);
}
Tcl_DStringEndSublist(dsPtr);
@@ -716,7 +706,7 @@ static void
MoveObjs(
Cache *fromPtr,
Cache *toPtr,
- int numMove)
+ size_t numMove)
{
Tcl_Obj *objPtr = fromPtr->firstObjPtr;
Tcl_Obj *fromFirstObjPtr = objPtr;
@@ -729,10 +719,10 @@ MoveObjs(
* to be moved) as the first object in the 'from' cache.
*/
- while (--numMove) {
- objPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ while (numMove-- > 1) {
+ objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
}
- fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
@@ -763,9 +753,9 @@ MoveObjs(
static void
PutObjs(
Cache *fromPtr,
- int numMove)
+ size_t numMove)
{
- int keep = fromPtr->numObjects - numMove;
+ size_t keep = fromPtr->numObjects - numMove;
Tcl_Obj *firstPtr, *lastPtr = NULL;
fromPtr->numObjects = keep;
@@ -775,8 +765,8 @@ PutObjs(
} else {
do {
lastPtr = firstPtr;
- firstPtr = firstPtr->internalRep.twoPtrValue.ptr1;
- } while (--keep > 0);
+ firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1;
+ } while (keep-- > 1);
lastPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
@@ -813,11 +803,11 @@ PutObjs(
*----------------------------------------------------------------------
*/
-static char *
+static void *
Block2Ptr(
Block *blockPtr,
int bucket,
- unsigned int reqSize)
+ size_t reqSize)
{
void *ptr;
@@ -828,12 +818,12 @@ Block2Ptr(
#if RCHECK
((unsigned char *)(ptr))[reqSize] = MAGIC;
#endif
- return (char *) ptr;
+ return ptr;
}
static Block *
Ptr2Block(
- char *ptr)
+ void *ptr)
{
Block *blockPtr;
@@ -881,7 +871,7 @@ LockBucket(
static void
UnlockBucket(
- Cache *cachePtr,
+ TCL_UNUSED(Cache *),
int bucket)
{
Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
@@ -907,14 +897,14 @@ static void
PutBlocks(
Cache *cachePtr,
int bucket,
- int numMove)
+ size_t numMove)
{
/*
* We have numFree. Want to shed numMove. So compute how many
* Blocks to keep.
*/
- int keep = cachePtr->buckets[bucket].numFree - numMove;
+ size_t keep = cachePtr->buckets[bucket].numFree - numMove;
Block *lastPtr = NULL, *firstPtr;
cachePtr->buckets[bucket].numFree = keep;
@@ -925,7 +915,7 @@ PutBlocks(
do {
lastPtr = firstPtr;
firstPtr = firstPtr->nextBlock;
- } while (--keep > 0);
+ } while (keep-- > 1);
lastPtr->nextBlock = NULL;
}
@@ -970,7 +960,7 @@ GetBlocks(
int bucket)
{
Block *blockPtr;
- int n;
+ size_t n;
/*
* First, atttempt to move blocks from the shared cache. Note the
@@ -1003,7 +993,7 @@ GetBlocks(
cachePtr->buckets[bucket].firstPtr = blockPtr;
sharedPtr->buckets[bucket].numFree -= n;
cachePtr->buckets[bucket].numFree = n;
- while (--n > 0) {
+ while (n-- > 1) {
blockPtr = blockPtr->nextBlock;
}
sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
@@ -1024,8 +1014,8 @@ GetBlocks(
blockPtr = NULL;
n = NBUCKETS;
- size = 0; /* lint */
- while (--n > bucket) {
+ size = 0;
+ while (n-- > (size_t)bucket + 1) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
@@ -1041,7 +1031,7 @@ GetBlocks(
if (blockPtr == NULL) {
size = MAXALLOC;
- blockPtr = TclpSysAlloc(size, 0);
+ blockPtr = (Block*)TclpSysAlloc(size, 0);
if (blockPtr == NULL) {
return 0;
}
@@ -1054,7 +1044,7 @@ GetBlocks(
n = size / bucketInfo[bucket].blockSize;
cachePtr->buckets[bucket].numFree = n;
cachePtr->buckets[bucket].firstPtr = blockPtr;
- while (--n > 0) {
+ while (n-- > 1) {
blockPtr->nextBlock = (Block *)
((char *) blockPtr + bucketInfo[bucket].blockSize);
blockPtr = blockPtr->nextBlock;
@@ -1064,6 +1054,40 @@ GetBlocks(
}
return 1;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitThreadAlloc --
+ *
+ * Initializes the allocator cache-maintenance structures.
+ * It is done early and protected during the Tcl_InitSubsystems().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitThreadAlloc(void)
+{
+ unsigned int i;
+
+ listLockPtr = TclpNewAllocMutex();
+ objLockPtr = TclpNewAllocMutex();
+ for (i = 0; i < NBUCKETS; ++i) {
+ bucketInfo[i].blockSize = MINALLOC << i;
+ bucketInfo[i].maxBlocks = ((size_t)1) << (NBUCKETS - 1 - i);
+ bucketInfo[i].numMove = i < NBUCKETS - 1 ?
+ (size_t)1 << (NBUCKETS - 2 - i) : 1;
+ bucketInfo[i].lockPtr = TclpNewAllocMutex();
+ }
+ TclpInitAllocCache();
+}
/*
*----------------------------------------------------------------------
@@ -1122,7 +1146,7 @@ TclFinalizeThreadAlloc(void)
void
TclFinalizeThreadAllocThread(void)
{
- Cache *cachePtr = TclpGetAllocCache();
+ Cache *cachePtr = (Cache *)TclpGetAllocCache();
if (cachePtr != NULL) {
TclpFreeAllocCache(cachePtr);
}
@@ -1147,7 +1171,7 @@ TclFinalizeThreadAllocThread(void)
void
Tcl_GetMemoryInfo(
- Tcl_DString *dsPtr)
+ TCL_UNUSED(Tcl_DString *))
{
Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
}
diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c
index 5c70a62..4d2aca5 100644
--- a/generic/tclThreadJoin.c
+++ b/generic/tclThreadJoin.c
@@ -6,7 +6,7 @@
* provide the functionality of joining threads. This code is currently
* not necessary on Unix.
*
- * Copyright (c) 2000 by Scriptics Corporation
+ * Copyright © 2000 Scriptics Corporation
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -230,7 +230,7 @@ TclRememberJoinableThread(
{
JoinableThread *threadPtr;
- threadPtr = ckalloc(sizeof(JoinableThread));
+ threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
@@ -305,6 +305,8 @@ TclSignalExitThread(
Tcl_MutexUnlock(&threadPtr->threadMutex);
}
+#else
+TCL_MAC_EMPTY_FILE(generic_tclThreadJoin_c)
#endif /* _WIN32 */
/*
diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c
index ad8c50f..b2de9b4 100644
--- a/generic/tclThreadStorage.c
+++ b/generic/tclThreadStorage.c
@@ -4,8 +4,8 @@
* 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
+ * Copyright © 2003-2004 Joe Mistachkin
+ * Copyright © 2008 George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -13,7 +13,7 @@
#include "tclInt.h"
-#ifdef TCL_THREADS
+#if TCL_THREADS
#include <signal.h>
/*
@@ -85,14 +85,14 @@ TSDTableCreate(void)
TSDTable *tsdTablePtr;
sig_atomic_t i;
- tsdTablePtr = TclpSysAlloc(sizeof(TSDTable), 0);
+ tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0);
if (tsdTablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
tsdTablePtr->allocated = 8;
tsdTablePtr->tablePtr =
- TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
+ (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
if (tsdTablePtr->tablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
@@ -148,15 +148,15 @@ TSDTableGrow(
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
- ClientData *newTablePtr;
+ void **newTablePtr;
sig_atomic_t i;
if (newAllocated <= atLeast) {
newAllocated = atLeast + 10;
}
- newTablePtr = TclpSysRealloc(tsdTablePtr->tablePtr,
- sizeof(ClientData) * newAllocated);
+ newTablePtr = (void **)TclpSysRealloc(tsdTablePtr->tablePtr,
+ sizeof(void *) * newAllocated);
if (newTablePtr == NULL) {
Tcl_Panic("unable to reallocate TSDTable");
}
@@ -189,7 +189,7 @@ void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
ClientData resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
@@ -223,7 +223,7 @@ TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
@@ -288,7 +288,7 @@ TclThreadStorageKeySet(
void
TclFinalizeThreadDataThread(void)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index ff18077..03446c2 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -6,8 +6,8 @@
* Some of this code is based on work done by Richard Hipp on behalf of
* Conservation Through Innovation, Limited, with their permission.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 2006-2008 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.
@@ -18,7 +18,7 @@
#endif
#include "tclInt.h"
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Each thread has an single instance of the following structure. There is one
* instance of this structure per thread even if that thread contains multiple
@@ -119,9 +119,7 @@ static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
-static int ThreadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ThreadObjCmd;
static int ThreadCreate(Tcl_Interp *interp, const char *script,
int joinable);
static int ThreadList(Tcl_Interp *interp);
@@ -130,15 +128,15 @@ static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
const char *result, int flags);
-static Tcl_ThreadCreateType NewTestThread(ClientData clientData);
+static Tcl_ThreadCreateType NewTestThread(void *clientData);
static void ListRemove(ThreadSpecificData *tsdPtr);
static void ListUpdateInner(ThreadSpecificData *tsdPtr);
static int ThreadEventProc(Tcl_Event *evPtr, int mask);
static void ThreadErrorProc(Tcl_Interp *interp);
-static void ThreadFreeProc(ClientData clientData);
+static void ThreadFreeProc(void *clientData);
static int ThreadDeleteEvent(Tcl_Event *eventPtr,
- ClientData clientData);
-static void ThreadExitProc(ClientData clientData);
+ void *clientData);
+static void ThreadExitProc(void *clientData);
extern int Tcltest_Init(Tcl_Interp *interp);
/*
@@ -203,10 +201,9 @@ TclThread_Init(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -272,7 +269,7 @@ ThreadObjCmd(
} else {
result = NULL;
}
- return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
+ return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
}
case THREAD_CREATE: {
const char *script;
@@ -336,11 +333,11 @@ ThreadObjCmd(
*/
if (objc == 2) {
- idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(Tcl_GetCurrentThread()));
} else if (objc == 3
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
Tcl_MutexLock(&threadMutex);
- idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(mainThreadId));
Tcl_MutexUnlock(&threadMutex);
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -365,13 +362,13 @@ ThreadObjCmd(
return TCL_ERROR;
}
- result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
+ result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
- char buf[20];
+ char buf[TCL_INTEGER_SPACE];
- sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", (long long)id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
@@ -407,14 +404,14 @@ ThreadObjCmd(
}
arg++;
script = Tcl_GetString(objv[arg]);
- return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
+ return ThreadSend(interp, (Tcl_ThreadId)INT2PTR(id), script, wait);
}
case THREAD_EVENT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
return TCL_OK;
}
@@ -435,7 +432,7 @@ ThreadObjCmd(
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
- errorProcString = ckalloc(strlen(proc) + 1);
+ errorProcString = (char *)ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
@@ -491,7 +488,6 @@ ThreadObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
@@ -508,7 +504,7 @@ ThreadCreate(
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
- if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
+ if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
@@ -556,9 +552,9 @@ ThreadCreate(
Tcl_ThreadCreateType
NewTestThread(
- ClientData clientData)
+ void *clientData)
{
- ThreadCtrl *ctrlPtr = clientData;
+ ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
@@ -595,7 +591,7 @@ NewTestThread(
* eval'ing, for the case that we exit during evaluation
*/
- threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
+ threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
@@ -654,9 +650,9 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ sprintf(buf, "%p", Tcl_GetCurrentThread());
- errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
@@ -840,13 +836,13 @@ ThreadSend(
* Create the event for its event queue.
*/
- threadEventPtr = ckalloc(sizeof(ThreadEvent));
- threadEventPtr->script = ckalloc(strlen(script) + 1);
+ threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
+ threadEventPtr->script = (char *)ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
- resultPtr = ckalloc(sizeof(ThreadEventResult));
+ resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
@@ -880,8 +876,7 @@ ThreadSend(
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
- TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(threadId);
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
@@ -1010,7 +1005,7 @@ ThreadCancel(
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
@@ -1031,8 +1026,8 @@ ThreadEventProc(
code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
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);
+ errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
@@ -1042,14 +1037,14 @@ ThreadEventProc(
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
- resultPtr->result = ckalloc(strlen(result) + 1);
+ resultPtr->result = (char *)ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
- resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
+ resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
- resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
+ resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
@@ -1073,15 +1068,14 @@ ThreadEventProc(
* None.
*
* Side effects:
- * Clears up mem specified in ClientData
+ * Clears up mem specified in clientData
*
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
ThreadFreeProc(
- ClientData clientData)
+ void *clientData)
{
if (clientData) {
ckfree(clientData);
@@ -1105,11 +1099,10 @@ ThreadFreeProc(
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
- ClientData clientData) /* dummy */
+ TCL_UNUSED(void *))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
@@ -1141,12 +1134,11 @@ ThreadDeleteEvent(
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
ThreadExitProc(
- ClientData clientData)
+ void *clientData)
{
- char *threadEvalScript = clientData;
+ char *threadEvalScript = (char *)clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -1199,7 +1191,7 @@ ThreadExitProc(
const char *msg = "target thread died";
- resultPtr->result = ckalloc(strlen(msg) + 1);
+ resultPtr->result = (char *)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 500a75e..e986db7 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -4,7 +4,7 @@
* This file provides timer event management facilities for Tcl,
* including the "after" command.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -91,7 +91,7 @@ typedef struct IdleHandler {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
int lastTimerId; /* Timer identifier of most recently created
* timer. */
@@ -182,7 +182,7 @@ static void TimerSetupProc(ClientData clientData, int flags);
static ThreadSpecificData *
InitTimer(void)
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -211,9 +211,9 @@ InitTimer(void)
static void
TimerExitProc(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
@@ -297,7 +297,7 @@ TclCreateAbsoluteTimerHandler(
TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
- timerHandlerPtr = ckalloc(sizeof(TimerHandler));
+ timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
@@ -398,7 +398,7 @@ Tcl_DeleteTimerHandler(
static void
TimerSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
@@ -456,7 +456,7 @@ TimerSetupProc(
static void
TimerCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
@@ -488,7 +488,7 @@ TimerCheckProc(
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
- timerEvPtr = ckalloc(sizeof(Tcl_Event));
+ timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
@@ -518,7 +518,7 @@ TimerCheckProc(
static int
TimerHandlerEventProc(
- Tcl_Event *evPtr, /* Event to service. */
+ TCL_UNUSED(Tcl_Event *),
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
@@ -625,7 +625,7 @@ Tcl_DoWhenIdle(
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
- idlePtr = ckalloc(sizeof(IdleHandler));
+ idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
@@ -776,10 +776,9 @@ TclServiceIdle(void)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_AfterObjCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -789,11 +788,11 @@ Tcl_AfterObjCmd(
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
- int index;
+ int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
- enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
+ enum afterSubCmdsEnum {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
@@ -806,9 +805,9 @@ Tcl_AfterObjCmd(
* doesn't already exist.
*/
- assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
+ assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
- assocPtr = ckalloc(sizeof(AfterAssocData));
+ assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
@@ -818,15 +817,9 @@ Tcl_AfterObjCmd(
* First lets see if the command was passed a number as the first argument.
*/
- if (objv[1]->typePtr == &tclIntType
-#ifndef TCL_WIDE_INT_IS_LONG
- || objv[1]->typePtr == &tclWideIntType
-#endif
- || 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) {
+ if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
+ != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -851,7 +844,7 @@ Tcl_AfterObjCmd(
if (objc == 2) {
return AfterDelay(interp, ms);
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+ afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
@@ -900,10 +893,10 @@ Tcl_AfterObjCmd(
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
- command = Tcl_GetStringFromObj(commandPtr, &length);
+ command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
- tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
+ tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
@@ -931,7 +924,7 @@ Tcl_AfterObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+ afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
@@ -1047,11 +1040,6 @@ AfterDelay(
if (iPtr->limit.timeEvent == NULL
|| 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 > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
@@ -1068,16 +1056,11 @@ AfterDelay(
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
- Tcl_Sleep((long) diff);
+ Tcl_Sleep((int) diff);
}
if (Tcl_AsyncReady()) {
if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
@@ -1091,7 +1074,7 @@ AfterDelay(
return TCL_ERROR;
}
}
- Tcl_GetTime(&now);
+ Tcl_GetTime(&now);
} while (TCL_TIME_BEFORE(now, endTime));
return TCL_OK;
}
@@ -1168,7 +1151,7 @@ static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
- AfterInfo *afterPtr = clientData;
+ AfterInfo *afterPtr = (AfterInfo *)clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
@@ -1266,14 +1249,13 @@ FreeAfterPtr(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
AfterCleanupProc(
ClientData clientData, /* Points to AfterAssocData for the
* interpreter. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
+ TCL_UNUSED(Tcl_Interp *))
{
- AfterAssocData *assocPtr = clientData;
+ AfterAssocData *assocPtr = (AfterAssocData *)clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 27afefd..27c4f98 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -22,20 +22,20 @@ scspec EXTERN
# Declare each of the functions in the Tcl tommath interface
declare 0 {
- int TclBN_epoch(void)
+ int MP_WUR TclBN_epoch(void)
}
declare 1 {
- int TclBN_revision(void)
+ int MP_WUR TclBN_revision(void)
}
declare 2 {
- mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 3 {
- mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c)
}
declare 4 {
- mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 5 {
void TclBN_mp_clamp(mp_int *a)
@@ -47,128 +47,128 @@ declare 7 {
void TclBN_mp_clear_multi(mp_int *a, ...)
}
declare 8 {
- mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b)
+ mp_ord MP_WUR TclBN_mp_cmp(const mp_int *a, const mp_int *b)
}
declare 9 {
- mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b)
+ mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, unsigned int b)
}
declare 10 {
- mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
+ mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
}
declare 11 {
- mp_err TclBN_mp_copy(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_copy(const mp_int *a, mp_int *b)
}
declare 12 {
- int TclBN_mp_count_bits(const mp_int *a)
+ int MP_WUR TclBN_mp_count_bits(const mp_int *a)
}
declare 13 {
- mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r)
+ mp_err MP_WUR TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r)
}
declare 14 {
- mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r)
+ mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *q, unsigned int *r)
}
declare 15 {
- mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q)
+ mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
- mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
+ mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
-declare 17 {
- mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r)
+declare 17 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r)
}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
- mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)
}
declare 20 {
- mp_err TclBN_mp_grow(mp_int *a, int size)
+ mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size)
}
declare 21 {
- mp_err TclBN_mp_init(mp_int *a)
+ mp_err MP_WUR TclBN_mp_init(mp_int *a)
}
declare 22 {
- mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b)
+ mp_err MP_WUR TclBN_mp_init_copy(mp_int *a, const mp_int *b)
}
declare 23 {
- mp_err TclBN_mp_init_multi(mp_int *a, ...)
+ mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...)
}
declare 24 {
- mp_err TclBN_mp_init_set(mp_int *a, mp_digit b)
+ mp_err MP_WUR TclBN_mp_init_set(mp_int *a, unsigned int b)
}
declare 25 {
- mp_err TclBN_mp_init_size(mp_int *a, int size)
+ mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size)
}
declare 26 {
- mp_err TclBN_mp_lshd(mp_int *a, int shift)
+ mp_err MP_WUR TclBN_mp_lshd(mp_int *a, int shift)
}
declare 27 {
- mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r)
+ mp_err MP_WUR TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r)
}
declare 28 {
- mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
+ mp_err MP_WUR TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
}
declare 29 {
- mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p)
}
declare 30 {
- mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p)
}
declare 31 {
- mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p)
}
declare 32 {
- mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
}
declare 33 {
- mp_err TclBN_mp_neg(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_neg(const mp_int *a, mp_int *b)
}
declare 34 {
- mp_err TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 35 {
- mp_err TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
+ mp_err MP_WUR TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
}
declare 36 {
- mp_err TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
+ mp_err MP_WUR TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
- mp_err TclBN_mp_shrink(mp_int *a)
+ mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
-declare 39 {
- void TclBN_mp_set(mp_int *a, mp_digit b)
+declare 39 {deprecated {macro calling mp_set_u64}} {
+ void TclBN_mp_set(mp_int *a, unsigned int b)
}
-declare 40 {
+declare 40 {nostub {is private function in libtommath}} {
mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b)
}
declare 41 {
- mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
- mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
- mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c)
}
-declare 44 {
+declare 44 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
}
-declare 45 {
+declare 45 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b,
unsigned long *outlen)
}
-declare 46 {
+declare 46 {deprecated {Use mp_to_radix}} {
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
}
declare 47 {
- size_t TclBN_mp_unsigned_bin_size(const mp_int *a)
+ size_t TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
- mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
@@ -177,107 +177,107 @@ declare 49 {
# internal routines to libtommath - should not be called but must be
# exported to accommodate the "tommath" extension
-declare 50 {
+declare 50 {deprecated {is private function in libtommath}} {
void TclBN_reverse(unsigned char *s, int len)
}
-declare 51 {
- mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
+declare 51 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
-declare 52 {
- mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b)
+declare 52 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b)
}
-declare 53 {
+declare 53 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 54 {
+declare 54 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b)
}
-declare 55 {
+declare 55 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 56 {
+declare 56 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b)
}
-declare 57 {
+declare 57 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 58 {
+declare 58 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
-declare 59 {
+declare 59 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b)
}
-declare 60 {
+declare 60 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 61 {
- mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i)
+declare 61 {deprecated {macro calling mp_init_u64}} {
+ mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i)
}
-declare 62 {
- mp_err TclBN_mp_set_int(mp_int *a, unsigned long i)
+declare 62 {deprecated {macro calling mp_set_u64}} {
+ void TclBN_mp_set_ul(mp_int *a, unsigned long i)
}
declare 63 {
- int TclBN_mp_cnt_lsb(const mp_int *a)
+ int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
-declare 64 {
- int TclBNInitBignumFromLong(mp_int *bignum, long initVal)
+declare 64 {deprecated {macro calling mp_init_i64}} {
+ int TclBN_mp_init_l(mp_int *bignum, long initVal)
}
declare 65 {
- int TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal)
+ int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
- int TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal)
+ int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
# Added in libtommath 1.0
-declare 67 {
- mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
+declare 67 {deprecated {Use mp_expt_u32}} {
+ mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast)
}
# Added in libtommath 1.0.1
declare 68 {
- void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i)
+ void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
- Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a)
+ uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
- void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i)
+ void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
declare 71 {
- mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
+ mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
}
declare 72 {
- mp_err TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
+ mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
size_t size, mp_endian endian, size_t nails, const mp_int *op)
}
# Added in libtommath 1.1.0
-declare 73 {
+declare 73 {deprecated {merged with mp_and}} {
mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 74 {
+declare 74 {deprecated {merged with mp_or}} {
mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 75 {
+declare 75 {deprecated {merged with mp_xor}} {
mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 76 {
- mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
- size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
+ size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
}
# Added in libtommath 1.2.0
declare 78 {
- int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
+ int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
declare 79 {
- mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r)
+ mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *q, uint64_t *r)
}
declare 80 {
- int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
+ int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index 79899e7..40a4e9d 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -1,1131 +1,47 @@
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
+#ifndef BN_TCL_H_
+#define BN_TCL_H_
-#ifndef BN_H_
-#define BN_H_
-
-#ifndef MODULE_SCOPE
-#define MODULE_SCOPE extern
-#endif
-
-
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
-#if (defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT)
-# define MP_32BIT
-#endif
-
-/* detect 64-bit mode if possible */
-#if defined(NEVER)
-# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
-# if defined(__GNUC__)
-/* we support 128bit integers only via: __attribute__((mode(TI))) */
-# define MP_64BIT
-# else
-/* otherwise we fall back to MP_32BIT even on 64bit platforms */
-# define MP_32BIT
-# endif
-# endif
-#endif
-
-#ifdef MP_DIGIT_BIT
-# error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT
-#endif
-
-/* some default configurations.
- *
- * A "mp_digit" must be able to hold MP_DIGIT_BIT + 1 bits
- * A "mp_word" must be able to hold 2*MP_DIGIT_BIT + 1 bits
- *
- * At the very least a mp_digit must be able to hold 7 bits
- * [any size beyond that is ok provided it doesn't overflow the data type]
- */
-
-#ifdef MP_8BIT
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned char mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-typedef unsigned short private_mp_word;
-#define MP_WORD_DECLARED
-#endif
-# define MP_SIZEOF_MP_DIGIT 1
-# ifdef MP_DIGIT_BIT
-# error You must not define MP_DIGIT_BIT when using MP_8BIT
-# endif
-#elif defined(MP_16BIT)
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned short mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-typedef unsigned int private_mp_word;
-#define MP_WORD_DECLARED
-#endif
-# define MP_SIZEOF_MP_DIGIT 2
-# ifdef MP_DIGIT_BIT
-# error You must not define MP_DIGIT_BIT when using MP_16BIT
-# endif
-#elif defined(MP_64BIT)
-/* for GCC only on supported platforms */
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned long long mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-typedef unsigned long private_mp_word __attribute__((mode(TI)));
-# define MP_DIGIT_BIT 60
-#else
-/* this is the default case, 28-bit digits */
-
-/* this is to make porting into LibTomCrypt easier :-) */
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned int mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-#ifdef _WIN32
-typedef unsigned __int64 private_mp_word;
-#else
-typedef unsigned long long private_mp_word;
-#endif
-#define MP_WORD_DECLARED
-#endif
-
-# ifdef MP_31BIT
-/*
- * This is an extension that uses 31-bit digits.
- * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast
- * will be reduced to work on small numbers only:
- * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT.
- */
-# define MP_DIGIT_BIT 31
+#ifdef MP_NO_STDINT
+# ifdef HAVE_STDINT_H
+# include <stdint.h>
# else
-/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-# define MP_DIGIT_BIT 28
-# define MP_28BIT
+# include "../compat/stdint.h"
# endif
#endif
-
-/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
-#ifndef MP_DIGIT_BIT
-# define MP_DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */
-#endif
-
-#define MP_MASK ((((mp_digit)1)<<((mp_digit)MP_DIGIT_BIT))-((mp_digit)1))
-#define MP_DIGIT_MAX MP_MASK
-
-/* Primality generation flags */
-#define MP_PRIME_BBS 0x0001 /* BBS style prime */
-#define MP_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */
-#define MP_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */
-
-#define LTM_PRIME_BBS (MP_DEPRECATED_PRAGMA("LTM_PRIME_BBS has been deprecated, use MP_PRIME_BBS") MP_PRIME_BBS)
-#define LTM_PRIME_SAFE (MP_DEPRECATED_PRAGMA("LTM_PRIME_SAFE has been deprecated, use MP_PRIME_SAFE") MP_PRIME_SAFE)
-#define LTM_PRIME_2MSB_ON (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON)
-
-#ifdef MP_USE_ENUMS
-typedef enum {
- MP_ZPOS = 0, /* positive */
- MP_NEG = 1 /* negative */
-} mp_sign;
-typedef enum {
- MP_LT = -1, /* less than */
- MP_EQ = 0, /* equal */
- MP_GT = 1 /* greater than */
-} mp_ord;
-typedef enum {
- MP_NO = 0,
- MP_YES = 1
-} mp_bool;
-typedef enum {
- MP_OKAY = 0, /* no error */
- MP_ERR = -1, /* unknown error */
- MP_MEM = -2, /* out of mem */
- MP_VAL = -3, /* invalid input */
- MP_ITER = -4, /* maximum iterations reached */
- MP_BUF = -5 /* buffer overflow, supplied buffer too small */
-} mp_err;
-typedef enum {
- MP_LSB_FIRST = -1,
- MP_MSB_FIRST = 1
-} mp_order;
-typedef enum {
- MP_LITTLE_ENDIAN = -1,
- MP_NATIVE_ENDIAN = 0,
- MP_BIG_ENDIAN = 1
-} mp_endian;
-#else
-typedef int mp_sign;
-#define MP_ZPOS 0 /* positive integer */
-#define MP_NEG 1 /* negative */
-typedef int mp_ord;
-#define MP_LT -1 /* less than */
-#define MP_EQ 0 /* equal to */
-#define MP_GT 1 /* greater than */
-typedef int mp_bool;
-#define MP_YES 1
-#define MP_NO 0
-typedef int mp_err;
-#define MP_OKAY 0 /* no error */
-#define MP_ERR -1 /* unknown error */
-#define MP_MEM -2 /* out of mem */
-#define MP_VAL -3 /* invalid input */
-#define MP_RANGE (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL)
-#define MP_ITER -4 /* maximum iterations reached */
-#define MP_BUF -5 /* buffer overflow, supplied buffer too small */
-typedef int mp_order;
-#define MP_LSB_FIRST -1
-#define MP_MSB_FIRST 1
-typedef int mp_endian;
-#define MP_LITTLE_ENDIAN -1
-#define MP_NATIVE_ENDIAN 0
-#define MP_BIG_ENDIAN 1
-#endif
-
-/* tunable cutoffs */
-
-#ifndef MP_FIXED_CUTOFFS
-extern int
-KARATSUBA_MUL_CUTOFF,
-KARATSUBA_SQR_CUTOFF,
-TOOM_MUL_CUTOFF,
-TOOM_SQR_CUTOFF;
-#endif
-
-/* define this to use lower memory usage routines (exptmods mostly) */
-/* #define MP_LOW_MEM */
-
-/* default precision */
-#ifndef MP_PREC
-# ifndef MP_LOW_MEM
-# define MP_PREC 32 /* default digits of precision */
-# elif defined(MP_8BIT)
-# define MP_PREC 16 /* default digits of precision */
-# else
-# define MP_PREC 8 /* default digits of precision */
+#if defined(TCL_NO_TOMMATH_H)
+ typedef size_t mp_digit;
+ typedef int mp_sign;
+# define MP_ZPOS 0 /* positive integer */
+# define MP_NEG 1 /* negative */
+ typedef int mp_ord;
+# define MP_LT -1 /* less than */
+# define MP_EQ 0 /* equal to */
+# define MP_GT 1 /* greater than */
+ typedef int mp_err;
+# define MP_OKAY 0 /* no error */
+# define MP_ERR -1 /* unknown error */
+# define MP_MEM -2 /* out of mem */
+# define MP_VAL -3 /* invalid input */
+# define MP_ITER -4 /* maximum iterations reached */
+# define MP_BUF -5 /* buffer overflow, supplied buffer too small */
+# define MP_WUR /* nothing */
+# define mp_iszero(a) ((a)->used == 0)
+# define mp_isneg(a) ((a)->sign != 0)
+
+ /* the infamous mp_int structure */
+# ifndef MP_INT_DECLARED
+# define MP_INT_DECLARED
+ typedef struct mp_int mp_int;
# endif
-#endif
-
-/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
-#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1))
-
-#if defined(__GNUC__) && __GNUC__ >= 4
-# define MP_NULL_TERMINATED __attribute__((sentinel))
-#else
-# define MP_NULL_TERMINATED
-#endif
-
-/*
- * MP_WUR - warn unused result
- * ---------------------------
- *
- * The result of functions annotated with MP_WUR must be
- * checked and cannot be ignored.
- *
- * Most functions in libtommath return an error code.
- * This error code must be checked in order to prevent crashes or invalid
- * results.
- *
- * If you still want to avoid the error checks for quick and dirty programs
- * without robustness guarantees, you can `#define MP_WUR` before including
- * tommath.h, disabling the warnings.
- */
-#ifndef MP_WUR
-# if defined(__GNUC__) && __GNUC__ >= 4
-# define MP_WUR __attribute__((warn_unused_result))
-# else
-# define MP_WUR
-# endif
-#endif
-
-#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
-# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
-#elif defined(_MSC_VER) && _MSC_VER >= 1500
-# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
-#else
-# define MP_DEPRECATED(x)
-#endif
-
-#ifndef MP_NO_DEPRECATED_PRAGMA
-#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
-# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
-# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
-#elif defined(_MSC_VER) && _MSC_VER >= 1500
-# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
-#endif
-#endif
-
-#ifndef MP_DEPRECATED_PRAGMA
-# define MP_DEPRECATED_PRAGMA(s)
-#endif
-
-#define DIGIT_BIT MP_DIGIT_BIT
-#define USED(m) ((m)->used)
-#define DIGIT(m,k) ((m)->dp[(k)])
-#define SIGN(m) ((m)->sign)
-
-/* the infamous mp_int structure */
-#ifndef MP_INT_DECLARED
-#define MP_INT_DECLARED
-typedef struct mp_int mp_int;
-#endif
-struct mp_int {
- int used, alloc;
- mp_sign sign;
- mp_digit *dp;
+ struct mp_int {
+ int used, alloc;
+ mp_sign sign;
+ mp_digit *dp;
};
-/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
-typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
-typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback;
-
-/* error code to char* string */
-/*
-const char *mp_error_to_string(mp_err code) MP_WUR;
-*/
-
-/* ---> init and deinit bignum functions <--- */
-/* init a bignum */
-/*
-mp_err mp_init(mp_int *a) MP_WUR;
-*/
-
-/* free a bignum */
-/*
-void mp_clear(mp_int *a);
-*/
-
-/* init a null terminated series of arguments */
-/*
-mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR;
-*/
-
-/* clear a null terminated series of arguments */
-/*
-void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED;
-*/
-
-/* exchange two ints */
-/*
-void mp_exch(mp_int *a, mp_int *b);
-*/
-
-/* shrink ram required for a bignum */
-/*
-mp_err mp_shrink(mp_int *a) MP_WUR;
-*/
-
-/* grow an int to a given size */
-/*
-mp_err mp_grow(mp_int *a, int size) MP_WUR;
-*/
-
-/* init to a given number of digits */
-/*
-mp_err mp_init_size(mp_int *a, int size) MP_WUR;
-*/
-
-/* ---> Basic Manipulations <--- */
-#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
-#define mp_isodd(a) (((a)->used != 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
-#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
-#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)
-
-/* set to zero */
-/*
-void mp_zero(mp_int *a);
-*/
-
-/* get and set doubles */
-/*
-double mp_get_double(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_set_double(mp_int *a, double b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (int32_t) */
-#ifndef MP_NO_STDINT
-/*
-int32_t mp_get_i32(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_i32(mp_int *a, int32_t b);
-*/
-/*
-mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */
-#define mp_get_u32(a) ((uint32_t)mp_get_i32(a))
-/*
-void mp_set_u32(mp_int *a, uint32_t b);
-*/
-/*
-mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (int64_t) */
-/*
-int64_t mp_get_i64(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_i64(mp_int *a, int64_t b);
-*/
-/*
-mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */
-#define mp_get_u64(a) ((uint64_t)mp_get_i64(a))
-/*
-void mp_set_u64(mp_int *a, uint64_t b);
-*/
-/*
-mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
-*/
-
-/* get magnitude */
-/*
-uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
-*/
-/*
-uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
-*/
-#endif
-/*
-unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
-*/
-/*
-Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR;
-*/
-
-/* get integer, set integer (long) */
-/*
-long mp_get_l(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_l(mp_int *a, long b);
-*/
-/*
-mp_err mp_init_l(mp_int *a, long b) MP_WUR;
-*/
-
-/* get integer, set integer (unsigned long) */
-#define mp_get_ul(a) ((unsigned long)mp_get_l(a))
-/*
-void mp_set_ul(mp_int *a, unsigned long b);
-*/
-/*
-mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideInt) */
-/*
-Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_ll(mp_int *a, Tcl_WideInt b);
-*/
-/*
-mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideUInt) */
-#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a))
-/*
-void mp_set_ull(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR;
-*/
-
-/* set to single unsigned digit, up to MP_DIGIT_MAX */
-/*
-void mp_set(mp_int *a, mp_digit b);
-*/
-/*
-mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (deprecated) */
-/*
-MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* copy, b = a */
-/*
-mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* inits and copies, a = b */
-/*
-mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* trim unused digits */
-/*
-void mp_clamp(mp_int *a);
-*/
-
-/* export binary data */
-/*
-MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
- int endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* import binary data */
-/*
-MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
- size_t size, int endian, size_t nails,
- const void *op) MP_WUR;
-*/
-
-/* unpack binary data */
-/*
-mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
- size_t nails, const void *op) MP_WUR;
-*/
-
-/* pack binary data */
-/*
-size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
- mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* ---> digit manipulation <--- */
-
-/* right shift by "b" digits */
-/*
-void mp_rshd(mp_int *a, int b);
-*/
-
-/* left shift by "b" digits */
-/*
-mp_err mp_lshd(mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a / 2**b, implemented as c = a >> b */
-/*
-mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* b = a/2 */
-/*
-mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/3 => 3c + d == a */
-/*
-mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a * 2**b, implemented as c = a << b */
-/*
-mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*2 */
-/*
-mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* c = a mod 2**b */
-/*
-mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* computes a = 2**b */
-/*
-mp_err mp_2expt(mp_int *a, int b) MP_WUR;
-*/
-
-/* Counts the number of lsbs which are zero before the first zero bit */
-/*
-int mp_cnt_lsb(const mp_int *a) MP_WUR;
-*/
-
-/* I Love Earth! */
-
-/* makes a pseudo-random mp_int of a given size */
-/*
-mp_err mp_rand(mp_int *a, int digits) MP_WUR;
-*/
-/* makes a pseudo-random small int of a given size */
-/*
-MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR;
-*/
-/* use custom random data source instead of source provided the platform */
-/*
-void mp_rand_source(mp_err(*source)(void *out, size_t size));
-*/
-
-#ifdef MP_PRNG_ENABLE_LTM_RNG
-/* A last resort to provide random data on systems without any of the other
- * implemented ways to gather entropy.
- * It is compatible with `rng_get_bytes()` from libtomcrypt so you could
- * provide that one and then set `ltm_rng = rng_get_bytes;` */
-extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
-extern void (*ltm_rng_callback)(void);
+#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
+# include "tommath.h"
#endif
-
-/* ---> binary operations <--- */
-
-/* Checks the bit at position b and returns MP_YES
- * if the bit is 1, MP_NO if it is 0 and MP_VAL
- * in case of error
- */
-/*
-MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a XOR b (two complement) */
-/*
-MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a OR b (two complement) */
-/*
-MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a AND b (two complement) */
-/*
-MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = ~a (bitwise not, two complement) */
-/*
-mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* right shift with sign extension */
-/*
-MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* ---> Basic arithmetic <--- */
-
-/* b = -a */
-/*
-mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* b = |a| */
-/*
-mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* compare a to b */
-/*
-mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* compare |a| to |b| */
-/*
-mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*a */
-/*
-mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* Increment "a" by one like "a++". Changes input! */
-/*
-mp_err mp_incr(mp_int *a) MP_WUR;
-*/
-
-/* Decrement "a" by one like "a--". Changes input! */
-/*
-mp_err mp_decr(mp_int *a) MP_WUR;
-*/
-
-/* ---> single digit functions <--- */
-
-/* compare against a single digit */
-/*
-mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
-*/
-
-/* ---> number theory <--- */
-
-/* d = a + b (mod c) */
-/*
-mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a - b (mod c) */
-/*
-mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a * b (mod c) */
-/*
-mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a * a (mod b) */
-/*
-mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = 1/a (mod b) */
-/*
-mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = (a, b) */
-/*
-mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* produces value such that U1*a + U2*b = U3 */
-/*
-mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
-*/
-
-/* c = [a, b] or (a*b)/(a, b) */
-/*
-mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* finds one of the b'th root of a, such that |c|**b <= |a|
- *
- * returns error if a < 0 and b is even
- */
-/*
-mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* special sqrt algo */
-/*
-mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR;
-*/
-
-/* special sqrt (mod prime) */
-/*
-mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
-*/
-
-/* is number a square? */
-/*
-mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR;
-*/
-
-/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
-/*
-MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
-*/
-
-/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
-/*
-mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR;
-*/
-
-/* used to setup the Barrett reduction for a given modulus b */
-/*
-mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* Barrett Reduction, computes a (mod b) with a precomputed value c
- *
- * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
- * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
- */
-/*
-mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR;
-*/
-
-/* setups the montgomery reduction */
-/*
-mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
-*/
-
-/* computes a = B**n mod b without division or multiplication useful for
- * normalizing numbers in a Montgomery system.
- */
-/*
-mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* computes x/R == x (mod N) via Montgomery Reduction */
-/*
-mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
-*/
-
-/* returns 1 if a is a valid DR modulus */
-/*
-mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR;
-*/
-
-/* sets the value of "d" required for mp_dr_reduce */
-/*
-void mp_dr_setup(const mp_int *a, mp_digit *d);
-*/
-
-/* reduces a modulo n using the Diminished Radix method */
-/*
-mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k */
-/*
-mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k_l */
-/*
-mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR;
-*/
-
-/* Y = G**X (mod P) */
-/*
-mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
-*/
-
-/* ---> Primes <--- */
-
-/* number of primes */
-#ifdef MP_8BIT
-# define PRIVATE_MP_PRIME_TAB_SIZE 31
-#else
-# define PRIVATE_MP_PRIME_TAB_SIZE 256
-#endif
-#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
-
-/* table of first PRIME_SIZE primes */
-#if defined(BUILD_tcl) || !defined(_WIN32)
-MODULE_SCOPE const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
-#endif
-
-/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
-/*
-MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Fermat test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Miller-Rabin test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* This gives [for a given bit size] the number of trials required
- * such that Miller-Rabin gives a prob of failure lower than 2^-96
- */
-/*
-int mp_prime_rabin_miller_trials(int size) MP_WUR;
-*/
-
-/* performs one strong Lucas-Selfridge test of "a".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Frobenius test of "a" as described by Paul Underwood.
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
-*/
-
-/* performs t random rounds of Miller-Rabin on "a" additional to
- * bases 2 and 3. Also performs an initial sieve of trial
- * division. Determines if "a" is prime with probability
- * of error no more than (1/4)**t.
- * Both a strong Lucas-Selfridge to complete the BPSW test
- * and a separate Frobenius test are available at compile time.
- * With t<0 a deterministic test is run for primes up to
- * 318665857834031151167461. With t<13 (abs(t)-13) additional
- * tests with sequential small primes are run starting at 43.
- * Is Fips 186.4 compliant if called with t as computed by
- * mp_prime_rabin_miller_trials();
- *
- * Sets result to 1 if probably prime, 0 otherwise
- */
-/*
-mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR;
-*/
-
-/* finds the next prime after the number "a" using "t" trials
- * of Miller-Rabin.
- *
- * bbs_style = 1 means the prime must be congruent to 3 mod 4
- */
-/*
-mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
-*/
-
-/* makes a truly random prime of a given size (bytes),
- * call with bbs = 1 if you want it to be congruent to 3 mod 4
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- * The prime generated will be larger than 2^(8*size).
- */
-#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat))
-
-/* makes a truly random prime of a given size (bits),
- *
- * Flags are as follows:
- *
- * MP_PRIME_BBS - make prime congruent to 3 mod 4
- * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS)
- * MP_PRIME_2MSB_ON - make the 2nd highest bit one
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- */
-/*
-MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
- private_mp_prime_callback cb, void *dat) MP_WUR;
-*/
-/*
-mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
-*/
-
-/* Integer logarithm to integer base */
-/*
-mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR;
-*/
-
-/* c = a**b */
-/*
-mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* ---> radix conversion <--- */
-/*
-int mp_count_bits(const mp_int *a) MP_WUR;
-*/
-
-
-/*
-MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-size_t mp_ubin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-size_t mp_sbin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
-*/
-/*
-mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
-*/
-/*
-mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR;
-*/
-
-#ifndef MP_NO_FILE
-/*
-mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
-/*
-mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
-#endif
-
-#define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len)))
-#define mp_raw_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_signed_bin_size") mp_signed_bin_size(mp))
-#define mp_toraw(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_signed_bin") mp_to_signed_bin((mp), (str)))
-#define mp_read_mag(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_unsigned_bin") mp_read_unsigned_bin((mp), (str), (len))
-#define mp_mag_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_unsigned_bin_size") mp_unsigned_bin_size(mp))
-#define mp_tomag(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_unsigned_bin") mp_to_unsigned_bin((mp), (str)))
-
-#define mp_tobinary(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_binary") mp_toradix((M), (S), 2))
-#define mp_tooctal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_octal") mp_toradix((M), (S), 8))
-#define mp_todecimal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_decimal") mp_toradix((M), (S), 10))
-#define mp_tohex(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_hex") mp_toradix((M), (S), 16))
-
-#define mp_to_binary(M, S, N) mp_to_radix((M), (S), (N), NULL, 2)
-#define mp_to_octal(M, S, N) mp_to_radix((M), (S), (N), NULL, 8)
-#define mp_to_decimal(M, S, N) mp_to_radix((M), (S), (N), NULL, 10)
-#define mp_to_hex(M, S, N) mp_to_radix((M), (S), (N), NULL, 16)
-
-#ifdef __cplusplus
-}
-#endif
-
#include "tclTomMathDecls.h"
#endif
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index e6f23aa..009f914 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -16,6 +16,7 @@
#define _TCLTOMMATHDECLS
#include "tcl.h"
+#include <string.h>
#ifndef BN_H_
#include "tclTomMath.h"
#endif
@@ -42,51 +43,86 @@
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (ckfree((char*)(x)))
+#undef MP_MALLOC
+#undef MP_CALLOC
+#undef MP_REALLOC
+#undef MP_FREE
#define MP_MALLOC(size) TclBNAlloc(size)
#define MP_CALLOC(nmemb, size) TclBNCalloc(nmemb, size)
#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
#define MP_FREE(mem, size) TclBNFree(mem)
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
+MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b);
+MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c);
+MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
+MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c);
+MODULE_SCOPE const char *const TclBN_mp_s_rmap;
+MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[];
+MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz;
+MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b);
+#ifdef __cplusplus
+}
+#endif
/* Rename the global symbols in libtommath to avoid linkage conflicts */
+#ifndef TCL_WITH_EXTERNAL_TOMMATH
#define bn_reverse TclBN_reverse
#define mp_add TclBN_mp_add
-#define mp_add_d TclBN_mp_add_d
+#define mp_add_d TclBN_s_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
-#define mp_cmp_d TclBN_mp_cmp_d
+#define mp_cmp_d TclBN_s_mp_cmp_d
#define mp_cmp_mag TclBN_mp_cmp_mag
#define mp_cnt_lsb TclBN_mp_cnt_lsb
#define mp_copy TclBN_mp_copy
#define mp_count_bits TclBN_mp_count_bits
#define mp_div TclBN_mp_div
+#define mp_div_d TclBN_s_mp_div_d
#define mp_div_2 TclBN_mp_div_2
+#define mp_div_3 TclBN_s_mp_div_3
#define mp_div_2d TclBN_mp_div_2d
-#define mp_div_3 TclBN_mp_div_3
-#define mp_div_d TclBN_mp_div_d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_expt_d_ex TclBN_mp_expt_d_ex
-#define mp_expt_u32 TclBN_mp_expt_d
-#define mp_get_mag_ull TclBN_mp_get_mag_ull
+#define mp_expt_u32 TclBN_s_mp_expt_u32
+#define mp_get_mag_u64 TclBN_mp_get_mag_u64
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
+#define mp_init_i64 TclBN_mp_init_i64
#define mp_init_multi TclBN_mp_init_multi
-#define mp_init_set TclBN_mp_init_set
-#define mp_init_set_int TclBN_mp_init_set_int
+#define mp_init_set TclBN_s_mp_init_set
#define mp_init_size TclBN_mp_init_size
+#define mp_init_u64 TclBN_mp_init_u64
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
+#define mp_mul_d TclBN_s_mp_mul_d
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
-#define mp_mul_d TclBN_mp_mul_d
#define mp_neg TclBN_mp_neg
#define mp_or TclBN_mp_or
#define mp_pack TclBN_mp_pack
@@ -94,18 +130,17 @@
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
-#define mp_set TclBN_mp_set
-#define mp_set_int(a,b) (TclBN_mp_set_int(a,(unsigned int)(b)),MP_OKAY)
-#define mp_set_ll TclBN_mp_set_ll
-#define mp_set_long(a,b) (TclBN_mp_set_int(a,b),MP_OKAY)
-#define mp_set_ul(a,b) (void)TclBN_mp_set_int(a,b)
-#define mp_set_ull TclBN_mp_set_ull
-#define mp_set_u64 TclBN_mp_set_ull
+#define mp_s_rmap TclBN_mp_s_rmap
+#define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse
+#define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz
+#define mp_set TclBN_s_mp_set
+#define mp_set_i64 TclBN_mp_set_i64
+#define mp_set_u64 TclBN_mp_set_u64
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
-#define mp_sub_d TclBN_mp_sub_d
+#define mp_sub_d TclBN_s_mp_sub_d
#define mp_signed_rsh TclBN_mp_signed_rsh
#define mp_tc_and TclBN_mp_and
#define mp_tc_div_2d TclBN_mp_signed_rsh
@@ -116,23 +151,29 @@
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_to_radix TclBN_mp_to_radix
#define mp_to_ubin TclBN_mp_to_ubin
+#define mp_ubin_size TclBN_mp_ubin_size
#define mp_unpack TclBN_mp_unpack
-#define mp_ubin_size TclBN_mp_unsigned_bin_size
-#define mp_unsigned_bin_size(a) ((int)TclBN_mp_unsigned_bin_size(a))
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
-#define s_mp_balance_mul TclBN_mp_balance_mul
+#define s_mp_balance_mul TclBN_s_mp_balance_mul
#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define s_mp_mul_digs TclBN_s_mp_mul_digs
-#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs
+#define s_mp_mul_digs_fast TclBN_s_mp_mul_digs_fast
#define s_mp_reverse TclBN_s_mp_reverse
#define s_mp_sqr TclBN_s_mp_sqr
-#define s_mp_sqr_fast TclBN_fast_s_mp_sqr
+#define s_mp_sqr_fast TclBN_s_mp_sqr_fast
#define s_mp_sub TclBN_s_mp_sub
#define s_mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_sqr TclBN_mp_toom_sqr
+#endif /* !TCL_WITH_EXTERNAL_TOMMATH */
+
+#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b)))
+#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY))
+#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY))
+#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY))
+#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp))
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
@@ -162,18 +203,18 @@ extern "C" {
*/
/* 0 */
-EXTERN int TclBN_epoch(void);
+EXTERN int TclBN_epoch(void) MP_WUR;
/* 1 */
-EXTERN int TclBN_revision(void);
+EXTERN int TclBN_revision(void) MP_WUR;
/* 2 */
EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 3 */
-EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 4 */
EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 5 */
EXTERN void TclBN_mp_clamp(mp_int *a);
/* 6 */
@@ -181,277 +222,298 @@ EXTERN void TclBN_mp_clear(mp_int *a);
/* 7 */
EXTERN void TclBN_mp_clear_multi(mp_int *a, ...);
/* 8 */
-EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b);
+EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
/* 9 */
-EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b);
+EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, unsigned int b) MP_WUR;
/* 10 */
-EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b);
+EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
/* 11 */
-EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b) MP_WUR;
/* 12 */
-EXTERN int TclBN_mp_count_bits(const mp_int *a);
+EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR;
/* 13 */
EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b,
- mp_int *q, mp_int *r);
+ mp_int *q, mp_int *r) MP_WUR;
/* 14 */
-EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b,
- mp_int *q, mp_digit *r);
+EXTERN mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b,
+ mp_int *q, unsigned int *r) MP_WUR;
/* 15 */
-EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q);
+EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR;
/* 16 */
EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
- mp_int *r);
+ mp_int *r) MP_WUR;
/* 17 */
-EXTERN mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q,
- mp_digit *r);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q,
+ unsigned int *r);
/* 18 */
EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b);
/* 19 */
-EXTERN mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 20 */
-EXTERN mp_err TclBN_mp_grow(mp_int *a, int size);
+EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR;
/* 21 */
-EXTERN mp_err TclBN_mp_init(mp_int *a);
+EXTERN mp_err TclBN_mp_init(mp_int *a) MP_WUR;
/* 22 */
-EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b);
+EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
/* 23 */
-EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...);
+EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR;
/* 24 */
-EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b);
+EXTERN mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) MP_WUR;
/* 25 */
-EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size);
+EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR;
/* 26 */
-EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift);
+EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift) MP_WUR;
/* 27 */
EXTERN mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b,
- mp_int *r);
+ mp_int *r) MP_WUR;
/* 28 */
-EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r);
+EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR;
/* 29 */
EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b,
- mp_int *p);
+ mp_int *p) MP_WUR;
/* 30 */
-EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b,
- mp_int *p);
+EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b,
+ mp_int *p) MP_WUR;
/* 31 */
-EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p);
+EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR;
/* 32 */
-EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p);
+EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) MP_WUR;
/* 33 */
-EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b) MP_WUR;
/* 34 */
EXTERN mp_err TclBN_mp_or(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 35 */
EXTERN mp_err TclBN_mp_radix_size(const mp_int *a, int radix,
- int *size);
+ int *size) MP_WUR;
/* 36 */
EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str,
- int radix);
+ int radix) MP_WUR;
/* 37 */
EXTERN void TclBN_mp_rshd(mp_int *a, int shift);
/* 38 */
-EXTERN mp_err TclBN_mp_shrink(mp_int *a);
+EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR;
/* 39 */
-EXTERN void TclBN_mp_set(mp_int *a, mp_digit b);
+TCL_DEPRECATED("macro calling mp_set_u64")
+void TclBN_mp_set(mp_int *a, unsigned int b);
/* 40 */
EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b);
/* 41 */
-EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR;
/* 42 */
EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 43 */
-EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 44 */
-EXTERN mp_err TclBN_mp_to_unsigned_bin(const mp_int *a,
+TCL_DEPRECATED("Use mp_to_ubin")
+mp_err TclBN_mp_to_unsigned_bin(const mp_int *a,
unsigned char *b);
/* 45 */
-EXTERN mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a,
+TCL_DEPRECATED("Use mp_to_ubin")
+mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a,
unsigned char *b, unsigned long *outlen);
/* 46 */
-EXTERN mp_err TclBN_mp_toradix_n(const mp_int *a, char *str,
+TCL_DEPRECATED("Use mp_to_radix")
+mp_err TclBN_mp_toradix_n(const mp_int *a, char *str,
int radix, int maxlen);
/* 47 */
-EXTERN size_t TclBN_mp_unsigned_bin_size(const mp_int *a);
+EXTERN size_t TclBN_mp_ubin_size(const mp_int *a);
/* 48 */
EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 49 */
EXTERN void TclBN_mp_zero(mp_int *a);
/* 50 */
-EXTERN void TclBN_reverse(unsigned char *s, int len);
+TCL_DEPRECATED("is private function in libtommath")
+void TclBN_reverse(unsigned char *s, int len);
/* 51 */
-EXTERN mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a,
const mp_int *b, mp_int *c, int digs);
/* 52 */
-EXTERN mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b);
/* 53 */
-EXTERN mp_err TclBN_mp_karatsuba_mul(const mp_int *a,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_karatsuba_mul(const mp_int *a,
const mp_int *b, mp_int *c);
/* 54 */
-EXTERN mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
/* 55 */
-EXTERN mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b,
mp_int *c);
/* 56 */
-EXTERN mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
/* 57 */
-EXTERN mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b,
mp_int *c);
/* 58 */
-EXTERN mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b,
mp_int *c, int digs);
/* 59 */
-EXTERN mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
/* 60 */
-EXTERN mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b,
mp_int *c);
/* 61 */
-EXTERN mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i);
+TCL_DEPRECATED("macro calling mp_init_u64")
+mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i);
/* 62 */
-EXTERN mp_err TclBN_mp_set_int(mp_int *a, unsigned long i);
+TCL_DEPRECATED("macro calling mp_set_u64")
+void TclBN_mp_set_ul(mp_int *a, unsigned long i);
/* 63 */
-EXTERN int TclBN_mp_cnt_lsb(const mp_int *a);
+EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR;
/* 64 */
-EXTERN int TclBNInitBignumFromLong(mp_int *bignum, long initVal);
+TCL_DEPRECATED("macro calling mp_init_i64")
+int TclBN_mp_init_l(mp_int *bignum, long initVal);
/* 65 */
-EXTERN int TclBNInitBignumFromWideInt(mp_int *bignum,
- Tcl_WideInt initVal);
+EXTERN int TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) MP_WUR;
/* 66 */
-EXTERN int TclBNInitBignumFromWideUInt(mp_int *bignum,
- Tcl_WideUInt initVal);
+EXTERN int TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) MP_WUR;
/* 67 */
-EXTERN mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b,
+TCL_DEPRECATED("Use mp_expt_u32")
+mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b,
mp_int *c, int fast);
/* 68 */
-EXTERN void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i);
+EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i);
/* 69 */
-EXTERN Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a);
+EXTERN uint64_t TclBN_mp_get_mag_u64(const mp_int *a) MP_WUR;
/* 70 */
-EXTERN void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i);
+EXTERN void TclBN_mp_set_i64(mp_int *a, int64_t i);
/* 71 */
EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count,
mp_order order, size_t size,
mp_endian endian, size_t nails,
- const void *op);
+ const void *op) MP_WUR;
/* 72 */
EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount,
size_t *written, mp_order order, size_t size,
mp_endian endian, size_t nails,
- const mp_int *op);
+ const mp_int *op) MP_WUR;
/* 73 */
-EXTERN mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_and")
+mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
mp_int *c);
/* 74 */
-EXTERN mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_or")
+mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
mp_int *c);
/* 75 */
-EXTERN mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_xor")
+mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
mp_int *c);
/* 76 */
EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 77 */
EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails,
- size_t size);
+ size_t size) MP_WUR;
/* 78 */
EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf,
- size_t maxlen, size_t *written);
+ size_t maxlen, size_t *written) MP_WUR;
/* 79 */
-EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b,
- mp_int *q, Tcl_WideUInt *r);
+EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b,
+ mp_int *q, uint64_t *r) MP_WUR;
/* 80 */
EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str,
- size_t maxlen, size_t *written, int radix);
+ size_t maxlen, size_t *written, int radix) MP_WUR;
typedef struct TclTomMathStubs {
int magic;
void *hooks;
- int (*tclBN_epoch) (void); /* 0 */
- int (*tclBN_revision) (void); /* 1 */
- mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */
- mp_err (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */
- mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */
+ int (*tclBN_epoch) (void) MP_WUR; /* 0 */
+ int (*tclBN_revision) (void) MP_WUR; /* 1 */
+ mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 2 */
+ mp_err (*tclBN_mp_add_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 3 */
+ mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 4 */
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 */
- mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b); /* 8 */
- mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b); /* 9 */
- mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */
- mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */
- int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */
- mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */
- mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */
- mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */
- mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */
- mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */
+ mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b) MP_WUR; /* 8 */
+ mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, unsigned int b) MP_WUR; /* 9 */
+ mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */
+ mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */
+ int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
+ mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
+ mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */
+ mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
+ mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r); /* 17 */
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
- mp_err (*tclBN_mp_expt_d) (const mp_int *a, unsigned int b, mp_int *c); /* 19 */
- mp_err (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */
- mp_err (*tclBN_mp_init) (mp_int *a); /* 21 */
- mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */
- mp_err (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */
- mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */
- mp_err (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */
- mp_err (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */
- mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */
- mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */
- mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */
- mp_err (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */
- mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */
- mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */
- mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */
- mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */
- mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */
- mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */
+ mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */
+ mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
+ mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
+ mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
+ mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
+ mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */
+ mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */
+ mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */
+ mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r) MP_WUR; /* 27 */
+ mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r) MP_WUR; /* 28 */
+ mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 29 */
+ mp_err (*tclBN_mp_mul_d) (const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 30 */
+ mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p) MP_WUR; /* 31 */
+ mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p) MP_WUR; /* 32 */
+ mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */
+ mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 34 */
+ mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size) MP_WUR; /* 35 */
+ mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */
void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
- mp_err (*tclBN_mp_shrink) (mp_int *a); /* 38 */
- void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */
- mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */
- mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */
- mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */
- mp_err (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */
- mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
- mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
- mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
- size_t (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */
- mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */
+ mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */
+ TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */
+ mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */
+ mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */
+ mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */
+ TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
+ TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
+ TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
+ size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */
+ mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */
void (*tclBN_mp_zero) (mp_int *a); /* 49 */
- void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */
- mp_err (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */
- mp_err (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */
- mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */
- mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */
- mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */
- mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */
- mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */
- mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */
- mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */
- mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */
- mp_err (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */
- mp_err (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */
- int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */
- int (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */
- int (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */
- int (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */
- mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
- void (*tclBN_mp_set_ull) (mp_int *a, Tcl_WideUInt i); /* 68 */
- Tcl_WideUInt (*tclBN_mp_get_mag_ull) (const mp_int *a); /* 69 */
- void (*tclBN_mp_set_ll) (mp_int *a, Tcl_WideInt i); /* 70 */
- mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op); /* 71 */
- mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op); /* 72 */
- mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
- mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
- mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
- mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */
- size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size); /* 77 */
- int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); /* 78 */
- mp_err (*tclBN_mp_div_ld) (const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r); /* 79 */
- int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); /* 80 */
+ TCL_DEPRECATED_API("is private function in libtommath") void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs_fast) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr_fast) (const mp_int *a, mp_int *b); /* 52 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */
+ TCL_DEPRECATED_API("macro calling mp_init_u64") mp_err (*tclBN_mp_init_ul) (mp_int *a, unsigned long i); /* 61 */
+ TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set_ul) (mp_int *a, unsigned long i); /* 62 */
+ int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */
+ TCL_DEPRECATED_API("macro calling mp_init_i64") int (*tclBN_mp_init_l) (mp_int *bignum, long initVal); /* 64 */
+ int (*tclBN_mp_init_i64) (mp_int *bignum, int64_t initVal) MP_WUR; /* 65 */
+ int (*tclBN_mp_init_u64) (mp_int *bignum, uint64_t initVal) MP_WUR; /* 66 */
+ TCL_DEPRECATED_API("Use mp_expt_u32") mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, unsigned int b, mp_int *c, int fast); /* 67 */
+ void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */
+ uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */
+ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */
+ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */
+ mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */
+ TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
+ TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
+ TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
+ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */
+ size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */
+ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */
+ mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */
+ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -504,8 +566,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */
#define TclBN_mp_exch \
(tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */
-#define TclBN_mp_expt_d \
- (tclTomMathStubsPtr->tclBN_mp_expt_d) /* 19 */
+#define TclBN_mp_expt_u32 \
+ (tclTomMathStubsPtr->tclBN_mp_expt_u32) /* 19 */
#define TclBN_mp_grow \
(tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */
#define TclBN_mp_init \
@@ -560,18 +622,18 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */
#define TclBN_mp_toradix_n \
(tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */
-#define TclBN_mp_unsigned_bin_size \
- (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */
+#define TclBN_mp_ubin_size \
+ (tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */
#define TclBN_mp_xor \
(tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */
#define TclBN_mp_zero \
(tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */
#define TclBN_reverse \
(tclTomMathStubsPtr->tclBN_reverse) /* 50 */
-#define TclBN_fast_s_mp_mul_digs \
- (tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */
-#define TclBN_fast_s_mp_sqr \
- (tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */
+#define TclBN_s_mp_mul_digs_fast \
+ (tclTomMathStubsPtr->tclBN_s_mp_mul_digs_fast) /* 51 */
+#define TclBN_s_mp_sqr_fast \
+ (tclTomMathStubsPtr->tclBN_s_mp_sqr_fast) /* 52 */
#define TclBN_mp_karatsuba_mul \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */
#define TclBN_mp_karatsuba_sqr \
@@ -588,26 +650,26 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */
#define TclBN_s_mp_sub \
(tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */
-#define TclBN_mp_init_set_int \
- (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */
-#define TclBN_mp_set_int \
- (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */
+#define TclBN_mp_init_ul \
+ (tclTomMathStubsPtr->tclBN_mp_init_ul) /* 61 */
+#define TclBN_mp_set_ul \
+ (tclTomMathStubsPtr->tclBN_mp_set_ul) /* 62 */
#define TclBN_mp_cnt_lsb \
(tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */
-#define TclBNInitBignumFromLong \
- (tclTomMathStubsPtr->tclBNInitBignumFromLong) /* 64 */
-#define TclBNInitBignumFromWideInt \
- (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */
-#define TclBNInitBignumFromWideUInt \
- (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */
+#define TclBN_mp_init_l \
+ (tclTomMathStubsPtr->tclBN_mp_init_l) /* 64 */
+#define TclBN_mp_init_i64 \
+ (tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */
+#define TclBN_mp_init_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */
#define TclBN_mp_expt_d_ex \
(tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */
-#define TclBN_mp_set_ull \
- (tclTomMathStubsPtr->tclBN_mp_set_ull) /* 68 */
-#define TclBN_mp_get_mag_ull \
- (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */
-#define TclBN_mp_set_ll \
- (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */
+#define TclBN_mp_set_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_set_u64) /* 68 */
+#define TclBN_mp_get_mag_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_get_mag_u64) /* 69 */
+#define TclBN_mp_set_i64 \
+ (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */
#define TclBN_mp_unpack \
(tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */
#define TclBN_mp_pack \
@@ -633,15 +695,33 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
/* !END!: Do not edit above this line. */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
+#if defined(USE_TCL_STUBS)
+#undef mp_add_d
+#define mp_add_d TclBN_mp_add_d
+#undef mp_cmp_d
+#define mp_cmp_d TclBN_mp_cmp_d
+#undef mp_div_d
+#ifdef MP_64BIT
+#define mp_div_d TclBN_mp_div_ld
+#else
+#define mp_div_d TclBN_mp_div_d
+#endif
+#undef mp_sub_d
+#define mp_sub_d TclBN_mp_sub_d
+#undef mp_init_set
+#define mp_init_set TclBN_mp_init_set
+#undef mp_mul_d
+#define mp_mul_d TclBN_mp_mul_d
+#undef mp_set
+#define mp_set TclBN_mp_set
+#undef mp_expt_u32
+#define mp_expt_u32 TclBN_mp_expt_u32
+#endif /* USE_TCL_STUBS */
-#ifdef USE_TCL_STUBS
-#undef TclBNInitBignumFromLong
#define TclBNInitBignumFromLong(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)); \
+ (void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \
} \
@@ -650,7 +730,7 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
#define TclBNInitBignumFromWideInt(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)); \
+ (void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \
} \
@@ -659,27 +739,41 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
#define TclBNInitBignumFromWideUInt(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)); \
+ (void)mp_init_u64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \
} \
} while (0)
-#define mp_init_i32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_l(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ll(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_i64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ul(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ull(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#else
-#define mp_init_i32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_l(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ll(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_i64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ul(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ull(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#endif /* USE_TCL_STUBS */
+#undef mp_get_ll
+#define mp_get_ll(a) ((long long)mp_get_i64(a))
+#undef mp_set_ll
+#define mp_set_ll(a,b) mp_set_i64(a,b)
+#undef mp_init_ll
+#define mp_init_ll(a,b) mp_init_i64(a,b)
+#undef mp_get_ull
+#define mp_get_ull(a) ((unsigned long long)mp_get_i64(a))
+#undef mp_set_ull
+#define mp_set_ull(a,b) mp_set_u64(a,b)
+#undef mp_init_ull
+#define mp_init_ull(a,b) mp_init_u64(a,b)
+#undef mp_set
+#define mp_set(a,b) mp_set_i64((a),(int32_t)(b))
+#define mp_set_i32(a,b) mp_set_i64((a),(int32_t)(b))
+#define mp_set_l(a,b) mp_set_i64((a),(long)(b))
+#define mp_set_u32(a,b) mp_set_u64((a),(uint32_t)(b))
+#define mp_set_ul(a,b) mp_set_u64((a),(unsigned long)(b))
+#define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b))
+#define mp_init_l(a,b) mp_init_i64((a),(long)(b))
+#define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b))
+#define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b))
+#undef mp_iseven
+#undef mp_isodd
+#define mp_iseven(a) (!mp_isodd(a))
+#define mp_isodd(a) (((a)->used != 0) && (((a)->dp[0] & 1) != 0))
+#undef mp_sqr
+#define mp_sqr(a,b) mp_mul(a,a,b)
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
#endif /* _TCLINTDECLS */
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 21fd238..149ee34 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -6,14 +6,14 @@
* This file contains procedures that are used as a 'glue' layer between
* Tcl and libtommath.
*
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 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.
*/
#include "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
@@ -91,138 +91,6 @@ TclBN_revision(void)
}
/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromLong --
- *
- * Allocate and initialize a 'bignum' from a native 'long'.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromLong(
- mp_int *a,
- long initVal)
-{
- unsigned long v;
- mp_digit *p;
-
- /*
- * Allocate enough memory to hold the largest possible long
- */
-
- if (mp_init(a) != MP_OKAY) {
- Tcl_Panic("initialization failure in TclBNInitBignumFromLong");
- }
-
- /*
- * Convert arg to sign and magnitude.
- */
-
- if (initVal < 0) {
- a->sign = MP_NEG;
- v = -(unsigned long)initVal;
- } else {
- a->sign = MP_ZPOS;
- v = initVal;
- }
-
- /*
- * Store the magnitude in the bignum.
- */
-
- p = a->dp;
- while (v) {
- *p++ = (mp_digit) (v & MP_MASK);
- v >>= MP_DIGIT_BIT;
- }
- a->used = p - a->dp;
- return MP_OKAY;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromWideInt --
- *
- * Allocate and initialize a 'bignum' from a Tcl_WideInt
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromWideInt(
- mp_int *a, /* Bignum to initialize */
- Tcl_WideInt v) /* Initial value */
-{
- if (v < 0) {
- (void)TclBNInitBignumFromWideUInt(a, -(Tcl_WideUInt)v);
- return mp_neg(a, a);
- }
- (void)TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v);
- return MP_OKAY;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromWideUInt --
- *
- * Allocate and initialize a 'bignum' from a Tcl_WideUInt
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromWideUInt(
- mp_int *a, /* Bignum to initialize */
- Tcl_WideUInt v) /* Initial value */
-{
- mp_digit *p;
-
- /*
- * Allocate enough memory to hold the largest possible Tcl_WideUInt.
- */
-
- if (mp_init(a) != MP_OKAY) {
- Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt");
- }
-
- a->sign = 0;
-
- /*
- * Store the magnitude in the bignum.
- */
-
- p = a->dp;
- while (v) {
- *p++ = (mp_digit) (v & MP_MASK);
- v >>= MP_DIGIT_BIT;
- }
- a->used = p - a->dp;
- return MP_OKAY;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index 324f2a3..c0786c9 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -4,14 +4,15 @@
* 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.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 1998 Paul Duffin.
*
* 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 "tclTomMath.h"
MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr;
@@ -55,9 +56,9 @@ TclTomMathInitializeStubs(
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
- } else if(stubsPtr->tclBN_epoch() != epoch) {
+ } else if (stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
- } else if(stubsPtr->tclBN_revision() != revision) {
+ } else if (stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 8c1c79d..3e8844a 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -3,10 +3,10 @@
*
* This file contains code to handle most trace management.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
- * Copyright (c) 2002 ActiveState Corporation.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,8 +21,8 @@
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[1]; /* Space for Tcl command to invoke. Actual
+ Tcl_Size length; /* Number of non-NUL chars. in command. */
+ char command[TCLFLEXARRAY]; /* 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 1
@@ -41,10 +41,10 @@ typedef struct {
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
- size_t length; /* Number of non-NUL chars. in command. */
+ Tcl_Size length; /* Number of non-NUL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
- int startLevel; /* Used for bookkeeping with step execution
+ Tcl_Size startLevel; /* Used for bookkeeping with step execution
* traces, store the level at which the step
* trace was invoked */
char *startCmd; /* Used for bookkeeping with step execution
@@ -52,11 +52,11 @@ typedef struct {
* invoked step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
- int refCount; /* Used to ensure this structure is not
+ size_t refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
- char command[1]; /* Space for Tcl command to invoke. Actual
+ char command[TCLFLEXARRAY]; /* 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 1
@@ -79,8 +79,7 @@ typedef struct {
* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
* by the command being traced, not because of
* an internal trace.
- * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used
- * in command execution traces.
+ * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces.
*/
#define TCL_TRACE_ENTER_DURING_EXEC 4
@@ -93,8 +92,15 @@ typedef struct {
* Forward declarations for functions defined in this file:
*/
-typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex,
- int objc, Tcl_Obj *const objv[]);
+/* 'OLD' options are pre-Tcl-8.4 style */
+enum traceOptionsEnum {
+ TRACE_ADD, TRACE_INFO, TRACE_REMOVE
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
+#endif
+};
+typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
static Tcl_TraceTypeObjCmd TraceVariableObjCmd;
static Tcl_TraceTypeObjCmd TraceCommandObjCmd;
@@ -121,19 +127,19 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
*/
static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr,
- Command *cmdPtr, const char *command, int numChars,
- int objc, Tcl_Obj *const objv[]);
-static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp,
+ Command *cmdPtr, const char *command, Tcl_Size numChars,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
+static char * TraceVarProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
-static void TraceCommandProc(ClientData clientData,
+static void TraceCommandProc(void *clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static Tcl_CmdObjTraceProc TraceExecutionProc;
-static int StringTraceProc(ClientData clientData,
- Tcl_Interp *interp, int level,
+static int StringTraceProc(void *clientData,
+ Tcl_Interp *interp, Tcl_Size level,
const char *command, Tcl_Command commandInfo,
- int objc, Tcl_Obj *const objv[]);
-static void StringTraceDeleteProc(ClientData clientData);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
+static void StringTraceDeleteProc(void *clientData);
static void DisposeTraceResult(int flags, char *result);
static int TraceVarEx(Tcl_Interp *interp, const char *part1,
const char *part2, VarTrace *tracePtr);
@@ -143,8 +149,8 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1,
* trace procs
*/
-typedef struct StringTraceData {
- ClientData clientData; /* Client data from Tcl_CreateTrace */
+typedef struct {
+ void *clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
@@ -184,12 +190,11 @@ typedef struct StringTraceData {
int
Tcl_TraceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int optionIndex;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
const char *name;
const char *flagOps, *p;
@@ -202,13 +207,7 @@ Tcl_TraceObjCmd(
#endif
NULL
};
- /* 'OLD' options are pre-Tcl-8.4 style */
- enum traceOptions {
- TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
- TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
-#endif
- };
+ int optionIndex;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -219,7 +218,7 @@ Tcl_TraceObjCmd(
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum traceOptions) optionIndex) {
+ switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
/*
@@ -238,7 +237,7 @@ Tcl_TraceObjCmd(
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv);
}
case TRACE_INFO: {
/*
@@ -261,7 +260,7 @@ Tcl_TraceObjCmd(
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv);
break;
}
@@ -270,8 +269,7 @@ Tcl_TraceObjCmd(
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
- int code;
- int numFlags;
+ int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
@@ -280,7 +278,7 @@ Tcl_TraceObjCmd(
TclNewObj(opsList);
Tcl_IncrRefCount(opsList);
- flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
+ flagOps = TclGetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
@@ -314,7 +312,7 @@ Tcl_TraceObjCmd(
return code;
}
case TRACE_OLD_VINFO: {
- ClientData clientData;
+ void *clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
@@ -399,16 +397,12 @@ Tcl_TraceObjCmd(
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- enum traceOptions {
- TRACE_ADD, TRACE_INFO, TRACE_REMOVE
- };
+ Tcl_Size length;
static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
@@ -416,12 +410,13 @@ TraceExecutionObjCmd(
TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP
};
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
- int flags = 0;
- int i, listLen, result;
+ int flags = 0, result;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -434,7 +429,7 @@ TraceExecutionObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -446,6 +441,10 @@ TraceExecutionObjCmd(
NULL);
return TCL_ERROR;
}
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -466,11 +465,10 @@ TraceExecutionObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -497,7 +495,7 @@ TraceExecutionObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -556,7 +554,7 @@ TraceExecutionObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -576,7 +574,7 @@ TraceExecutionObjCmd(
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- int numOps = 0;
+ Tcl_Size numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -604,7 +602,7 @@ TraceExecutionObjCmd(
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
- TclListObjLength(NULL, elemObjPtr, &numOps);
+ TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
@@ -621,6 +619,10 @@ TraceExecutionObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -647,22 +649,21 @@ TraceExecutionObjCmd(
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ Tcl_Size length;
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
- int i, listLen;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -675,7 +676,7 @@ TraceCommandObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -687,7 +688,10 @@ TraceCommandObjCmd(
NULL);
return TCL_ERROR;
}
-
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -703,11 +707,10 @@ TraceCommandObjCmd(
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -730,7 +733,7 @@ TraceCommandObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -760,7 +763,7 @@ TraceCommandObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -779,7 +782,7 @@ TraceCommandObjCmd(
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- int numOps = 0;
+ Tcl_Size numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -799,7 +802,7 @@ TraceCommandObjCmd(
TclNewLiteralStringObj(opObj, "delete");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
- TclListObjLength(NULL, elemObjPtr, &numOps);
+ TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
@@ -815,6 +818,10 @@ TraceCommandObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -841,27 +848,26 @@ TraceCommandObjCmd(
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- ClientData clientData;
- enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ Tcl_Size length;
+ void *clientData;
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
};
enum operations {
TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE
};
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
- int i, listLen;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -874,7 +880,7 @@ TraceVariableObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -886,6 +892,10 @@ TraceVariableObjCmd(
NULL);
return TCL_ERROR;
}
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -906,11 +916,10 @@ TraceVariableObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc(
- TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+ offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
@@ -1007,6 +1016,10 @@ TraceVariableObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -1036,14 +1049,13 @@ TraceVariableObjCmd(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
- int flags, /* OR-ed combo or TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY (can be 0). */
+ TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
- ClientData prevClientData) /* If non-NULL, gives last value returned by
+ void *prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
@@ -1111,7 +1123,7 @@ Tcl_TraceCommand(
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
@@ -1175,7 +1187,7 @@ Tcl_UntraceCommand(
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
@@ -1280,7 +1292,7 @@ Tcl_UntraceCommand(
static void
TraceCommandProc(
- ClientData clientData, /* Information about the command trace. */
+ void *clientData, /* Information about the command trace. */
Tcl_Interp *interp, /* Interpreter containing command. */
const char *oldName, /* Name of command being changed. */
const char *newName, /* New name of command. Empty string or NULL
@@ -1421,18 +1433,17 @@ TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
- int numChars, /* The number of characters in 'command' which
- * are part of the command string. */
+ TCL_UNUSED(Tcl_Size) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
- int curLevel;
+ Tcl_Size curLevel;
int traceCode = TCL_OK;
Tcl_InterpState state = NULL;
@@ -1527,18 +1538,18 @@ TclCheckInterpTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
- int numChars, /* The number of characters in 'command' which
+ Tcl_Size numChars, /* The number of characters in 'command' which
* are part of the command string. */
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
- int curLevel;
+ Tcl_Size curLevel;
int traceCode = TCL_OK;
Tcl_InterpState state = NULL;
@@ -1674,9 +1685,9 @@ CallTraceFunction(
Command *cmdPtr, /* Points to command's Command struct. */
const char *command, /* Points to the first character of the
* command's source before substitutions. */
- int numChars, /* The number of characters in the command's
+ Tcl_Size numChars, /* The number of characters in the command's
* source. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
@@ -1721,7 +1732,7 @@ CallTraceFunction(
static void
CommandObjTraceDeleted(
- ClientData clientData)
+ void *clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -1757,12 +1768,12 @@ CommandObjTraceDeleted(
static int
TraceExecutionProc(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
- int level,
+ Tcl_Size level,
const char *command,
- Tcl_Command cmdInfo,
- int objc,
+ TCL_UNUSED(Tcl_Command),
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
int call = 0;
@@ -1817,7 +1828,8 @@ TraceExecutionProc(
if (call) {
Tcl_DString cmd, sub;
- int i, saveInterpFlags;
+ Tcl_Size i;
+ int saveInterpFlags;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length);
@@ -1964,7 +1976,7 @@ TraceExecutionProc(
static char *
TraceVarProc(
- ClientData clientData, /* Information about the variable trace. */
+ void *clientData, /* Information about the variable trace. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable or array. */
const char *name2, /* Name of element within array; NULL means
@@ -1979,7 +1991,7 @@ TraceVarProc(
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
- * We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
+ * We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
* of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
* it is not freed while we still need it.
@@ -2073,7 +2085,7 @@ TraceVarProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateObjTrace --
+ * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 --
*
* Arrange for a function to be called to trace command execution.
*
@@ -2086,7 +2098,7 @@ TraceVarProc(
* called to execute a Tcl command. Calls to proc will have the following
* form:
*
- * void proc(ClientData clientData,
+ * void proc(void * clientData,
* Tcl_Interp * interp,
* int level,
* const char * command,
@@ -2125,13 +2137,64 @@ TraceVarProc(
*----------------------------------------------------------------------
*/
+typedef struct {
+ Tcl_CmdObjTraceProc2 *proc;
+ Tcl_CmdObjTraceDeleteProc *delProc;
+ void *clientData;
+} TraceWrapperInfo;
+
+static int traceWrapperProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ Tcl_Size level,
+ const char *command,
+ Tcl_Command commandInfo,
+ Tcl_Size objc,
+ Tcl_Obj *const objv[])
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */
+ }
+ return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv);
+}
+
+static void traceWrapperDelProc(void *clientData)
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ clientData = info->clientData;
+ if (info->delProc) {
+ info->delProc(clientData);
+ }
+ ckfree(info);
+}
+
+Tcl_Trace
+Tcl_CreateObjTrace2(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_Size level, /* Maximum nesting level */
+ int flags, /* Flags, see above */
+ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */
+ void *clientData, /* Client data for the callback */
+ Tcl_CmdObjTraceDeleteProc *delProc)
+ /* Function to call when trace is deleted */
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)ckalloc(sizeof(TraceWrapperInfo));
+ info->proc = proc;
+ info->delProc = delProc;
+ info->clientData = clientData;
+ return Tcl_CreateObjTrace(interp, level, flags,
+ (proc ? traceWrapperProc : NULL),
+ info, traceWrapperDelProc);
+}
+
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
- int level, /* Maximum nesting level */
+ Tcl_Size level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
- ClientData clientData, /* Client data for the callback */
+ void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
@@ -2191,12 +2254,12 @@ Tcl_CreateObjTrace(
* void
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
* argc, argv)
- * ClientData clientData;
+ * void *clientData;
* Tcl_Interp *interp;
* int level;
* char *command;
* int (*cmdProc)();
- * ClientData cmdClientData;
+ * void *cmdClientData;
* int argc;
* char **argv;
* {
@@ -2217,11 +2280,11 @@ Tcl_CreateObjTrace(
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
- int level, /* Only call proc for commands at nesting
+ Tcl_Size level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
- ClientData clientData) /* Arbitrary value word to pass to proc. */
+ void *clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData));
@@ -2249,18 +2312,18 @@ Tcl_CreateTrace(
static int
StringTraceProc(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
- int level,
+ Tcl_Size level,
const char *command,
Tcl_Command commandInfo,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const *objv)
{
StringTraceData *data = (StringTraceData *)clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
- int i;
+ Tcl_Size i;
/*
* This is a bit messy because we have to emulate the old trace interface,
@@ -2305,7 +2368,7 @@ StringTraceProc(
static void
StringTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
ckfree(clientData);
}
@@ -2558,6 +2621,9 @@ TclObjCallVarTraces(
leaveErrMsg);
}
+#undef TCL_INTERP_DESTROYED
+#define TCL_INTERP_DESTROYED 0x100
+
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
@@ -2855,6 +2921,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
@@ -2870,6 +2937,7 @@ Tcl_UntraceVar(
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3024,6 +3092,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
@@ -3041,6 +3110,7 @@ Tcl_VarTraceInfo(
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3133,6 +3203,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
@@ -3150,6 +3221,7 @@ Tcl_TraceVar(
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3186,7 +3258,7 @@ Tcl_TraceVar2(
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index 33bdb8e..899c231 100644
--- a/generic/tclUniData.c
+++ b/generic/tclUniData.c
@@ -5,7 +5,7 @@
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
* All rights reserved.
*/
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index e4d0fc8..db2be84 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -3,7 +3,7 @@
*
* Routines for manipulating UTF-8 strings.
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -55,7 +55,7 @@
#define UNICODE_SELF 0x80
/*
- * The following structures are used when mapping between Unicode (UCS-2) and
+ * The following structures are used when mapping between Unicode and
* UTF-8.
*/
@@ -67,13 +67,7 @@ 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,
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
- 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
- 4,4,4,4,4,
-#else
- 1,1,1,1,1,
-#endif
- 1,1,1,1,1,1,1,1,1,1,1
+ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};
static const unsigned char complete[256] = {
@@ -86,30 +80,19 @@ static const unsigned char complete[256] = {
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
- 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
- 4,4,4,4,4,
-#else
- /* Tcl_UtfToUniChar() accesses src[1] and src[2] to check whether
- * the UTF-8 sequence is valid, so we cannot use 1 here. */
- 3,3,3,3,3,
-#endif
- 1,1,1,1,1,1,1,1,1,1,1
+ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};
-
+
/*
* Functions used only in this module.
*/
-static int UtfCount(int ch);
static int Invalid(const char *src);
-static int UCS4ToUpper(int ch);
-static int UCS4ToTitle(int ch);
/*
*---------------------------------------------------------------------------
*
- * UtfCount --
+ * TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
@@ -122,8 +105,8 @@ static int UCS4ToTitle(int ch);
*---------------------------------------------------------------------------
*/
-static inline int
-UtfCount(
+int
+TclUtfCount(
int ch) /* The Unicode character whose size is returned. */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
@@ -132,11 +115,9 @@ UtfCount(
if (ch <= 0x7FF) {
return 2;
}
-#if TCL_UTF_MAX > 3
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
-#endif
return 3;
}
@@ -174,13 +155,8 @@ static const unsigned char bounds[28] = {
0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */
0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
-#if TCL_UTF_MAX > 3
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
-#else
- 0xC0, 0xBF, /* Not used, but reject all again for safety. */
- 0xC0, 0xBF /* Not used, but reject all again for safety. */
-#endif
};
static int
@@ -209,6 +185,19 @@ Invalid(
* Stores the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
*
+ * Special handling of Surrogate pairs is handled as follows:
+ * When this function is called for ch being a high surrogate,
+ * the first byte of the 4-byte UTF-8 sequence is produced and
+ * the function returns 1. Calling the function again with a
+ * low surrogate, the remaining 3 bytes of the 4-byte UTF-8
+ * sequence is produced, and the function returns 3. The buffer
+ * is used to remember the high surrogate between the two calls.
+ *
+ * If no low surrogate follows the high surrogate (which is actually
+ * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf
+ * again with ch = -1. This will produce a 3-byte UTF-8 sequence
+ * representing the high surrogate.
+ *
* Results:
* Returns the number of bytes stored into the buffer.
*
@@ -225,7 +214,7 @@ Tcl_UniCharToUtf(
char *buf) /* Buffer in which the UTF-8 representation of
* the Tcl_UniChar is stored. Buffer must be
* large enough to hold the UTF-8 character
- * (at most TCL_UTF_MAX bytes). */
+ * (at most 4 bytes). */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
@@ -238,7 +227,6 @@ Tcl_UniCharToUtf(
return 2;
}
if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX > 3
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x0400) {
/* Low surrogate */
@@ -261,11 +249,8 @@ Tcl_UniCharToUtf(
return 1;
}
}
-#endif
goto three;
}
-
-#if TCL_UTF_MAX > 3
if (ch <= 0x10FFFF) {
buf[3] = (char) (0x80 | (0x3F & ch));
buf[2] = (char) (0x80 | (0x3F & (ch >> 6)));
@@ -286,7 +271,6 @@ Tcl_UniCharToUtf(
buf[-1] = (char) (0xE0 | (ch >> 12));
return 2;
}
-#endif
}
ch = 0xFFFD;
@@ -315,25 +299,35 @@ three:
*---------------------------------------------------------------------------
*/
+#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
- const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
- int uniLength, /* Length of Unicode string in Tcl_UniChars
- * (must be >= 0). */
+ const int *uniStr, /* Unicode string to convert to UTF-8. */
+ int uniLength, /* Length of Unicode string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
- const Tcl_UniChar *w, *wEnd;
+ const int *w, *wEnd;
char *p, *string;
int oldLength;
/*
- * UTF-8 string length in bytes will be <= Unicode string length *
- * TCL_UTF_MAX.
+ * UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
+ if (uniStr == NULL) {
+ return NULL;
+ }
+ if (uniLength < 0) {
+ uniLength = 0;
+ w = uniStr;
+ while (*w != '\0') {
+ uniLength++;
+ w++;
+ }
+ }
oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * TCL_UTF_MAX);
+ Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
@@ -347,6 +341,59 @@ Tcl_UniCharToUtfDString(
return string;
}
+char *
+Tcl_Char16ToUtfDString(
+ const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
+ int uniLength, /* Length of Utf-16 string. */
+ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
+ * to this previously initialized DString. */
+{
+ const unsigned short *w, *wEnd;
+ char *p, *string;
+ int oldLength, len = 1;
+
+ /*
+ * UTF-8 string length in bytes will be <= Utf16 string length * 3.
+ */
+
+ if (uniStr == NULL) {
+ return NULL;
+ }
+ if (uniLength < 0) {
+
+ uniLength = 0;
+ w = uniStr;
+ while (*w != '\0') {
+ uniLength++;
+ w++;
+ }
+ }
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3);
+ string = Tcl_DStringValue(dsPtr) + oldLength;
+
+ p = string;
+ wEnd = uniStr + uniLength;
+ for (w = uniStr; w < wEnd; ) {
+ if (!len && ((*w & 0xFC00) != 0xDC00)) {
+ /* Special case for handling high surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ len = Tcl_UniCharToUtf(*w, p);
+ p += len;
+ if ((*w >= 0xD800) && (len < 3)) {
+ len = 0; /* Indication that high surrogate was found */
+ }
+ w++;
+ }
+ if (!len) {
+ /* Special case for handling high surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
+
+ return string;
+}
/*
*---------------------------------------------------------------------------
*
@@ -382,27 +429,119 @@ Tcl_UniCharToUtfDString(
*---------------------------------------------------------------------------
*/
+static const unsigned short cp1252[32] = {
+ 0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
+ 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
+ 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
+ 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
+};
+
+#undef Tcl_UtfToUniChar
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
- Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
+ int *chPtr)/* Filled with the Unicode character represented by
* the UTF-8 string. */
{
- Tcl_UniChar byte;
+ int byte;
/*
- * Unroll 1 to 3 (or 4) byte UTF-8 sequences.
+ * Unroll 1 to 4 byte UTF-8 sequences.
+ */
+
+ byte = *((unsigned char *) src);
+ if (byte < 0xC0) {
+ /*
+ * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
+ * characters representing themselves.
+ */
+
+ if ((unsigned)(byte-0x80) < (unsigned)0x20) {
+ *chPtr = cp1252[byte-0x80];
+ } else {
+ *chPtr = byte;
+ }
+ return 1;
+ } else if (byte < 0xE0) {
+ if ((src[1] & 0xC0) == 0x80) {
+ /*
+ * Two-byte-character lead-byte followed by a trail-byte.
+ */
+
+ *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F));
+ if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) {
+ return 2;
+ }
+ }
+
+ /*
+ * A two-byte-character lead-byte not followed by trail-byte
+ * represents itself.
+ */
+ } else if (byte < 0xF0) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
+ /*
+ * Three-byte-character lead byte followed by two trail bytes.
+ */
+
+ *chPtr = (((byte & 0x0F) << 12)
+ | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F));
+ if (*chPtr > 0x7FF) {
+ return 3;
+ }
+ }
+
+ /*
+ * A three-byte-character lead-byte not followed by two trail-bytes
+ * represents itself.
+ */
+ } else if (byte < 0xF5) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
+ /*
+ * Four-byte-character lead byte followed by three trail bytes.
+ */
+ *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
+ if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
+ return 4;
+ }
+ }
+
+ /*
+ * A four-byte-character lead-byte not followed by three trail-bytes
+ * represents itself.
+ */
+ }
+
+ *chPtr = byte;
+ return 1;
+}
+
+int
+Tcl_UtfToChar16(
+ const char *src, /* The UTF-8 string. */
+ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
+ * the UTF-8 string. This could be a surrogate too. */
+{
+ unsigned short byte;
+
+ /*
+ * Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
- * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
-#if TCL_UTF_MAX <= 4
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
@@ -415,8 +554,11 @@ Tcl_UtfToUniChar(
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
-#endif
- *chPtr = byte;
+ if ((unsigned)(byte-0x80) < (unsigned)0x20) {
+ *chPtr = cp1252[byte-0x80];
+ } else {
+ *chPtr = byte;
+ }
return 1;
} else if (byte < 0xE0) {
if ((src[1] & 0xC0) == 0x80) {
@@ -457,7 +599,6 @@ Tcl_UtfToUniChar(
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
-#if TCL_UTF_MAX <= 4
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high < 0x400) {
@@ -466,15 +607,6 @@ Tcl_UtfToUniChar(
return 1;
}
/* out of range, < 0x10000 or > 0x10FFFF */
-#else
- if ((src[3] & 0xC0) == 0x80) {
- *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
- | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
- if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
- return 4;
- }
- }
-#endif
}
/*
@@ -505,7 +637,8 @@ Tcl_UtfToUniChar(
*---------------------------------------------------------------------------
*/
-Tcl_UniChar *
+#undef Tcl_UtfToUniCharDString
+int *
Tcl_UtfToUniCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
@@ -514,7 +647,64 @@ Tcl_UtfToUniCharDString(
* appended to this previously initialized
* DString. */
{
- Tcl_UniChar ch = 0, *w, *wString;
+ int ch = 0, *w, *wString;
+ const char *p;
+ int oldLength;
+ /* Pointer to the end of string. Never read endPtr[0] */
+ const char *endPtr = src + length;
+ /* Pointer to last byte where optimization still can be used */
+ const char *optPtr = endPtr - TCL_UTF_MAX;
+
+ if (src == NULL) {
+ return NULL;
+ }
+ if (length < 0) {
+ length = strlen(src);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
+ * bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((length + 1) * sizeof(int)));
+ wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = src;
+ endPtr = src + length;
+ optPtr = endPtr - 4;
+ while (p <= optPtr) {
+ p += TclUtfToUCS4(p, &ch);
+ *w++ = ch;
+ }
+ while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) {
+ p += TclUtfToUCS4(p, &ch);
+ *w++ = ch;
+ }
+ while (p < endPtr) {
+ *w++ = UCHAR(*p++);
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((char *) w - (char *) wString));
+
+ return wString;
+}
+
+unsigned short *
+Tcl_UtfToChar16DString(
+ 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
+ * appended to this previously initialized
+ * DString. */
+{
+ unsigned short ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
@@ -522,6 +712,9 @@ Tcl_UtfToUniCharDString(
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
+ if (src == NULL) {
+ return NULL;
+ }
if (length < 0) {
length = strlen(src);
}
@@ -534,20 +727,20 @@ Tcl_UtfToUniCharDString(
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
- oldLength + ((length + 1) * sizeof(Tcl_UniChar)));
- wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
+ oldLength + ((length + 1) * sizeof(unsigned short)));
+ wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
- optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3) ;
+ optPtr = endPtr - 3;
while (p <= optPtr) {
- p += TclUtfToUniChar(p, &ch);
+ p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
if (Tcl_UtfCharComplete(p, endPtr-p)) {
- p += TclUtfToUniChar(p, &ch);
+ p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
@@ -607,7 +800,7 @@ Tcl_UtfCharComplete(
*/
int
-Tcl_NumUtfChars(
+TclNumUtfChars(
const char *src, /* The UTF-8 string to measure. */
int length) /* The length of the string in bytes, or -1
* for strlen(string). */
@@ -627,7 +820,7 @@ Tcl_NumUtfChars(
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
- const char *optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3);
+ const char *optPtr = endPtr - 4;
/*
* Optimize away the call in this loop. Justified because...
@@ -658,6 +851,61 @@ Tcl_NumUtfChars(
return i;
}
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_NumUtfChars
+int
+Tcl_NumUtfChars(
+ const char *src, /* The UTF-8 string to measure. */
+ int length) /* The length of the string in bytes, or -1
+ * for strlen(string). */
+{
+ unsigned short ch = 0;
+ int i = 0;
+
+ if (length < 0) {
+ /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
+ while ((*src != '\0') && (i < INT_MAX)) {
+ src += Tcl_UtfToChar16(src, &ch);
+ i++;
+ }
+ } else {
+ /* Will return value between 0 and length. No overflow checks. */
+
+ /* Pointer to the end of string. Never read endPtr[0] */
+ const char *endPtr = src + length;
+ /* Pointer to last byte where optimization still can be used */
+ const char *optPtr = endPtr - 4;
+
+ /*
+ * Optimize away the call in this loop. Justified because...
+ * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr)
+ * By initialization above (endPtr - optPtr) = TCL_UTF_MAX
+ * So (endPtr - src) >= TCL_UTF_MAX, and passing that to
+ * Tcl_UtfCharComplete we know will cause return of 1.
+ */
+ while (src <= optPtr
+ /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) {
+ src += Tcl_UtfToChar16(src, &ch);
+ i++;
+ }
+ /* Loop over the remaining string where call must happen */
+ while (src < endPtr) {
+ if (Tcl_UtfCharComplete(src, endPtr - src)) {
+ src += Tcl_UtfToChar16(src, &ch);
+ } else {
+ /*
+ * src points to incomplete UTF-8 sequence
+ * Treat first byte as character and count it
+ */
+ src++;
+ }
+ i++;
+ }
+ }
+ return i;
+}
+#endif
+
/*
*---------------------------------------------------------------------------
*
@@ -763,7 +1011,6 @@ Tcl_UtfNext(
int left;
const char *next;
-#if TCL_UTF_MAX > 3
if (((*src) & 0xC0) == 0x80) {
/* Continuation byte, so we start 'inside' a (possible valid) UTF-8
* sequence. Since we are not allowed to access src[-1], we cannot
@@ -774,7 +1021,6 @@ Tcl_UtfNext(
}
return src;
}
-#endif
left = totalBytes[UCHAR(*src)];
next = src + 1;
@@ -905,10 +1151,10 @@ Tcl_UtfPrev(
/* Continue the search backwards... */
look--;
- } while (trailBytesSeen < (TCL_UTF_MAX < 4 ? 3 : 4));
+ } while (trailBytesSeen < 4);
/*
- * We've seen 3 trail bytes, so we know there will not be a
+ * We've seen 4 trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
* accepting the fallback.
*/
@@ -920,7 +1166,7 @@ Tcl_UtfPrev(
*
* Tcl_UniCharAtIndex --
*
- * Returns the Tcl_UniChar represented at the specified character
+ * Returns the Unicode character represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
@@ -932,17 +1178,27 @@ Tcl_UtfPrev(
*---------------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
int index) /* The position of the desired character. */
{
- Tcl_UniChar ch = 0;
+ unsigned short ch = 0;
+ int i = 0;
- while (index-- >= 0) {
- src += TclUtfToUniChar(src, &ch);
+ if (index < 0) {
+ return -1;
}
- return ch;
+ while (index-- > 0) {
+ i = Tcl_UtfToChar16(src, &ch);
+ src += i;
+ }
+ if ((ch >= 0xD800) && (i < 3)) {
+ /* Index points at character following high Surrogate */
+ return -1;
+ }
+ TclUtfToUCS4(src, &i);
+ return i;
}
/*
@@ -951,7 +1207,9 @@ Tcl_UniCharAtIndex(
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
- * the UTF-8 string.
+ * the UTF-8 string. If TCL_UTF_MAX < 4, characters > U+FFFF count as
+ * 2 positions, but then the pointer should never be placed between
+ * the two positions.
*
* Results:
* As above.
@@ -962,27 +1220,56 @@ Tcl_UniCharAtIndex(
*---------------------------------------------------------------------------
*/
+#if TCL_UTF_MAX < 4
+# undef Tcl_UtfToUniChar
+# define Tcl_UtfToUniChar Tcl_UtfToChar16
+#endif
+
const char *
-Tcl_UtfAtIndex(
+TclUtfAtIndex(
const char *src, /* The UTF-8 string. */
int index) /* The position of the desired character. */
{
- Tcl_UniChar ch = 0;
+ Tcl_UniChar ch = 0;
int len = 0;
while (index-- > 0) {
- len = TclUtfToUniChar(src, &ch);
+ len = (Tcl_UtfToUniChar)(src, &ch);
src += len;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
- src += TclUtfToUniChar(src, &ch);
+ src += (Tcl_UtfToUniChar)(src, &ch);
}
#endif
return src;
}
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_UtfAtIndex
+const char *
+Tcl_UtfAtIndex(
+ const char *src, /* The UTF-8 string. */
+ int index) /* The position of the desired character. */
+{
+ unsigned short ch = 0;
+ int len = 0;
+
+ while (index-- > 0) {
+ len = Tcl_UtfToChar16(src, &ch);
+ src += len;
+ }
+ if ((ch >= 0xD800) && (len < 3)) {
+ /* Index points at character following high Surrogate */
+ src += Tcl_UtfToChar16(src, &ch);
+ }
+ return src;
+}
+
+
+#endif
+
/*
*---------------------------------------------------------------------------
*
@@ -992,7 +1279,7 @@ Tcl_UtfAtIndex(
*
* Results:
* Stores the bytes represented by the backslash sequence in dst and
- * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes
+ * returns the number of bytes written to dst. At most 4 bytes
* are written to dst; dst must have been large enough to accept those
* bytes. If readPtr isn't NULL then it is filled in with a count of the
* number of bytes in the backslash sequence.
@@ -1069,7 +1356,7 @@ Tcl_UtfToUpper(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
- upChar = UCS4ToUpper(ch);
+ upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1077,11 +1364,11 @@ Tcl_UtfToUpper(
* char to dst if its size is <= the original char.
*/
- if (len < UtfCount(upChar)) {
+ if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(upChar, dst);
+ dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
@@ -1122,7 +1409,7 @@ Tcl_UtfToLower(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
- lowChar = TclUCS4ToLower(ch);
+ lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1130,11 +1417,11 @@ Tcl_UtfToLower(
* char to dst if its size is <= the original char.
*/
- if (len < UtfCount(lowChar)) {
+ if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(lowChar, dst);
+ dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
@@ -1178,13 +1465,13 @@ Tcl_UtfToTitle(
if (*src) {
len = TclUtfToUCS4(src, &ch);
- titleChar = UCS4ToTitle(ch);
+ titleChar = Tcl_UniCharToTitle(ch);
- if (len < UtfCount(titleChar)) {
+ if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(titleChar, dst);
+ dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
@@ -1193,14 +1480,14 @@ Tcl_UtfToTitle(
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
- lowChar = TclUCS4ToLower(lowChar);
+ lowChar = Tcl_UniCharToLower(lowChar);
}
- if (len < UtfCount(lowChar)) {
+ if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(lowChar, dst);
+ dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
@@ -1296,7 +1583,7 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1347,7 +1634,7 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1366,6 +1653,52 @@ Tcl_UtfNcasecmp(
}
return 0;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfCmp --
+ *
+ * Compare UTF chars of string cs to string ct case sensitively.
+ * Replacement for strcmp in Tcl core, in places where UTF-8 should
+ * be handled.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCmp(
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct) /* UTF string cs is compared to. */
+{
+ Tcl_UniChar ch1 = 0, ch2 = 0;
+
+ while (*cs && *ct) {
+ cs += TclUtfToUniChar(cs, &ch1);
+ ct += TclUtfToUniChar(ct, &ch2);
+ if (ch1 != ch2) {
+#if TCL_UTF_MAX < 4
+ /* Surrogates always report higher than non-surrogates */
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
+ return ch1;
+ }
+ } else if ((ch2 & 0xFC00) == 0xD800) {
+ return -ch2;
+ }
+#endif
+ return ch1 - ch2;
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
/*
*----------------------------------------------------------------------
@@ -1396,7 +1729,7 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1433,8 +1766,8 @@ TclUtfCasecmp(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToUpper(
+int
+Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1447,13 +1780,6 @@ UCS4ToUpper(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
-
-Tcl_UniChar
-Tcl_UniCharToUpper(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) UCS4ToUpper(ch);
-}
/*
*----------------------------------------------------------------------
@@ -1472,7 +1798,7 @@ Tcl_UniCharToUpper(
*/
int
-TclUCS4ToLower(
+Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1487,13 +1813,6 @@ TclUCS4ToLower(
return ch & 0x1FFFFF;
}
-Tcl_UniChar
-Tcl_UniCharToLower(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) TclUCS4ToLower(ch);
-}
-
/*
*----------------------------------------------------------------------
*
@@ -1510,8 +1829,8 @@ Tcl_UniCharToLower(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToTitle(
+int
+Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1533,14 +1852,37 @@ UCS4ToTitle(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Char16Len --
+ *
+ * Find the length of a UniChar string. The str input must be null
+ * terminated.
+ *
+ * Results:
+ * Returns the length of str in UniChars (not bytes).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
-Tcl_UniChar
-Tcl_UniCharToTitle(
- int ch) /* Unicode character to convert. */
+int
+Tcl_Char16Len(
+ const unsigned short *uniStr) /* Unicode string to find length of. */
{
- return (Tcl_UniChar) UCS4ToTitle(ch);
+ int len = 0;
+
+ while (*uniStr != '\0') {
+ len++;
+ uniStr++;
+ }
+ return len;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1558,9 +1900,10 @@ Tcl_UniCharToTitle(
*----------------------------------------------------------------------
*/
+#undef Tcl_UniCharLen
int
Tcl_UniCharLen(
- const Tcl_UniChar *uniStr) /* Unicode string to find length of. */
+ const int *uniStr) /* Unicode string to find length of. */
{
int len = 0;
@@ -1589,12 +1932,40 @@ Tcl_UniCharLen(
*/
int
-Tcl_UniCharNcmp(
+TclUniCharNcmp(
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. */
{
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
+ /*
+ * We are definitely on a big-endian machine; memcmp() is safe
+ */
+
+ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
+
+#else /* !WORDS_BIGENDIAN */
+ /*
+ * We can't simply call memcmp() because that is not lexically correct.
+ */
+
+ for ( ; numChars != 0; ucs++, uct++, numChars--) {
+ if (*ucs != *uct) {
+ return (*ucs - *uct);
+ }
+ }
+ return 0;
+#endif /* WORDS_BIGENDIAN */
+}
+
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharNcmp(
+ const unsigned short *ucs, /* Unicode string to compare to uct. */
+ const unsigned short *uct, /* Unicode string ucs is compared to. */
+ unsigned long numChars) /* Number of unichars to compare. */
+{
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
@@ -1608,21 +1979,19 @@ Tcl_UniCharNcmp(
for ( ; numChars != 0; ucs++, uct++, numChars--) {
if (*ucs != *uct) {
-#if TCL_UTF_MAX == 4
/* special case for handling upper surrogates */
if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) {
return 1;
} else if (((*uct & 0xFC00) == 0xD800)) {
return -1;
}
-#endif
return (*ucs - *uct);
}
}
return 0;
#endif /* WORDS_BIGENDIAN */
}
-
+#endif
/*
*----------------------------------------------------------------------
*
@@ -1642,31 +2011,51 @@ Tcl_UniCharNcmp(
*/
int
-Tcl_UniCharNcasecmp(
+TclUniCharNcasecmp(
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++) {
if (*ucs != *uct) {
- Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
- Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
+ int lcs = Tcl_UniCharToLower(*ucs);
+ int lct = Tcl_UniCharToLower(*uct);
+
+ if (lcs != lct) {
+ return (lcs - lct);
+ }
+ }
+ }
+ return 0;
+}
+
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharNcasecmp(
+ const unsigned short *ucs, /* Unicode string to compare to uct. */
+ const unsigned short *uct, /* Unicode string ucs is compared to. */
+ unsigned long numChars) /* Number of unichars to compare. */
+{
+ for ( ; numChars != 0; numChars--, ucs++, uct++) {
+ if (*ucs != *uct) {
+ unsigned short lcs = Tcl_UniCharToLower(*ucs);
+ unsigned short lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
-#if TCL_UTF_MAX == 4
/* special case for handling upper surrogates */
if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) {
return 1;
} else if (((lct & 0xFC00) == 0xD800)) {
return -1;
}
-#endif
return (lcs - lct);
}
}
}
return 0;
}
+#endif
+
/*
*----------------------------------------------------------------------
@@ -1688,11 +2077,9 @@ int
Tcl_UniCharIsAlnum(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
@@ -1716,11 +2103,9 @@ int
Tcl_UniCharIsAlpha(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
@@ -1744,7 +2129,6 @@ int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
/* Clear away extension bits, if any */
ch &= 0x1FFFFF;
@@ -1756,7 +2140,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1780,11 +2163,9 @@ int
Tcl_UniCharIsDigit(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
@@ -1808,11 +2189,9 @@ int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
-#endif
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
@@ -1836,11 +2215,9 @@ int
Tcl_UniCharIsLower(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == LOWERCASE_LETTER);
}
@@ -1864,11 +2241,9 @@ int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
-#endif
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
@@ -1892,11 +2267,9 @@ int
Tcl_UniCharIsPunct(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
@@ -1920,13 +2293,8 @@ int
Tcl_UniCharIsSpace(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
/* Ignore upper 11 bits. */
ch &= 0x1FFFFF;
-#else
- /* Ignore upper 16 bits. */
- ch &= 0xFFFF;
-#endif
/*
* If the character is within the first 127 characters, just use the
@@ -1935,10 +2303,8 @@ Tcl_UniCharIsSpace(
if (ch < 0x80) {
return TclIsSpaceProcM((char) ch);
-#if TCL_UTF_MAX > 3
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
-#endif
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
@@ -1967,17 +2333,45 @@ int
Tcl_UniCharIsUpper(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == UPPERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_UniCharIsUnicode --
+ *
+ * Test if a character is a Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character belongs to the Unicode set.
+ *
+ * Excluded are:
+ * 1) All characters > U+10FFFF
+ * 2) Surrogates U+D800 - U+DFFF
+ * 3) Last 2 characters of each plane, so U+??FFFE and U+??FFFF
+ * 4) The characters in the range U+FDD0 - U+FDEF
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsUnicode(
+ int ch) /* Unicode character to test. */
+{
+ return ((unsigned int)ch <= 0x10FFFF) && ((ch & 0xFFF800) != 0xD800)
+ && ((ch & 0xFFFE) != 0xFFFE) && ((unsigned int)(ch - 0xFDD0) >= 32);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UniCharIsWordChar --
*
* Test if a character is alphanumeric or a connector punctuation mark.
@@ -1995,11 +2389,9 @@ int
Tcl_UniCharIsWordChar(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((WORD_BITS >> GetCategory(ch)) & 1);
}
@@ -2027,14 +2419,182 @@ Tcl_UniCharIsWordChar(
*/
int
-Tcl_UniCharCaseMatch(
+TclUniCharCaseMatch(
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 */
{
- Tcl_UniChar ch1 = 0, p;
+ int ch1 = 0, p;
+
+ while (1) {
+ p = *uniPattern;
+
+ /*
+ * See if we're at the end of both the pattern and the string. If so,
+ * we succeeded. If we're at the end of the pattern but not at the end
+ * of the string, we failed.
+ */
+
+ if (p == 0) {
+ return (*uniStr == 0);
+ }
+ if ((*uniStr == 0) && (p != '*')) {
+ return 0;
+ }
+
+ /*
+ * Check for a "*" as the next pattern character. It matches any
+ * substring. We handle this by skipping all the characters up to the
+ * next matching one in the pattern, and then calling ourselves
+ * recursively for each postfix of string, until either we match or we
+ * reach the end of the string.
+ */
+
+ if (p == '*') {
+ /*
+ * Skip all successive *'s in the pattern
+ */
+
+ while (*(++uniPattern) == '*') {
+ /* empty body */
+ }
+ p = *uniPattern;
+ if (p == 0) {
+ return 1;
+ }
+ if (nocase) {
+ p = Tcl_UniCharToLower(p);
+ }
+ while (1) {
+ /*
+ * Optimization for matching - cruise through the string
+ * quickly if the next char in the pattern isn't a special
+ * character
+ */
+
+ if ((p != '[') && (p != '?') && (p != '\\')) {
+ if (nocase) {
+ while (*uniStr && (p != *uniStr)
+ && (p != Tcl_UniCharToLower(*uniStr))) {
+ uniStr++;
+ }
+ } else {
+ while (*uniStr && (p != *uniStr)) {
+ uniStr++;
+ }
+ }
+ }
+ if (TclUniCharCaseMatch(uniStr, uniPattern, nocase)) {
+ return 1;
+ }
+ if (*uniStr == 0) {
+ return 0;
+ }
+ uniStr++;
+ }
+ }
+
+ /*
+ * Check for a "?" as the next pattern character. It matches any
+ * single character.
+ */
+
+ if (p == '?') {
+ uniPattern++;
+ uniStr++;
+ continue;
+ }
+
+ /*
+ * Check for a "[" as the next pattern character. It is followed by a
+ * list of characters that are acceptable, or by a range (two
+ * characters separated by "-").
+ */
+
+ if (p == '[') {
+ int startChar, endChar;
+
+ uniPattern++;
+ ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
+ uniStr++;
+ while (1) {
+ if ((*uniPattern == ']') || (*uniPattern == 0)) {
+ return 0;
+ }
+ startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
+ : *uniPattern);
+ uniPattern++;
+ if (*uniPattern == '-') {
+ uniPattern++;
+ if (*uniPattern == 0) {
+ return 0;
+ }
+ endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
+ : *uniPattern);
+ uniPattern++;
+ if (((startChar <= ch1) && (ch1 <= endChar))
+ || ((endChar <= ch1) && (ch1 <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+ break;
+ }
+ } else if (startChar == ch1) {
+ break;
+ }
+ }
+ while (*uniPattern != ']') {
+ if (*uniPattern == 0) {
+ uniPattern--;
+ break;
+ }
+ uniPattern++;
+ }
+ uniPattern++;
+ continue;
+ }
+
+ /*
+ * If the next pattern character is '\', just strip off the '\' so we
+ * do exact matching on the character that follows.
+ */
+
+ if (p == '\\') {
+ if (*(++uniPattern) == '\0') {
+ return 0;
+ }
+ }
+
+ /*
+ * There's no special character. Just make sure that the next bytes of
+ * each string match.
+ */
+
+ if (nocase) {
+ if (Tcl_UniCharToLower(*uniStr) !=
+ Tcl_UniCharToLower(*uniPattern)) {
+ return 0;
+ }
+ } else if (*uniStr != *uniPattern) {
+ return 0;
+ }
+ uniStr++;
+ uniPattern++;
+ }
+}
+
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharCaseMatch(
+ const unsigned short *uniStr, /* Unicode String. */
+ const unsigned short *uniPattern,
+ /* Pattern, which may contain special
+ * characters. */
+ int nocase) /* 0 for case sensitive, 1 for insensitive */
+{
+ unsigned short ch1 = 0, p;
while (1) {
p = *uniPattern;
@@ -2122,7 +2682,7 @@ Tcl_UniCharCaseMatch(
*/
if (p == '[') {
- Tcl_UniChar startChar, endChar;
+ unsigned short startChar, endChar;
uniPattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
@@ -2192,7 +2752,9 @@ Tcl_UniCharCaseMatch(
uniPattern++;
}
}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -2397,7 +2959,7 @@ TclUniCharMatch(
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
- * TclUCS4Complete() before calling this routine to ensure that
+ * Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
@@ -2410,30 +2972,17 @@ TclUniCharMatch(
*---------------------------------------------------------------------------
*/
+#if TCL_UTF_MAX < 4
int
TclUtfToUCS4(
const char *src, /* The UTF-8 string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the UTF-8 string. */
{
- Tcl_UniChar ch = 0;
- int len = Tcl_UtfToUniChar(src, &ch);
-
-#if TCL_UTF_MAX <= 4
- if ((ch & ~0x3FF) == 0xD800) {
- Tcl_UniChar low = ch;
- int len2 = Tcl_UtfToUniChar(src+len, &low);
- if ((low & ~0x3FF) == 0xDC00) {
- *ucs4Ptr = (((ch & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000;
- return len + len2;
- }
- }
-#endif
- *ucs4Ptr = (int)ch;
- return len;
+# undef Tcl_UtfToUniChar
+ return Tcl_UtfToUniChar(src, ucs4Ptr);
}
-#if TCL_UTF_MAX == 4
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
@@ -2441,62 +2990,27 @@ TclUniCharToUCS4(
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
- *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000;
+ *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[1] & 0x3FF)) + 0x10000;
return 2;
}
*ucs4Ptr = src[0];
return 1;
}
-#endif
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclUCS4ToUtf --
- *
- * Store the given Unicode character as a sequence of UTF-8 bytes in the
- * provided buffer. Might output 6 bytes, if the code point > 0xFFFF.
- *
- * Results:
- * The return values is the number of bytes in the buffer that were
- * consumed. If ch == -1, this function outputs 0 bytes (empty string),
- * since TclGetUCS4 returns -1 for out-of-range indices.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-int
-TclUCS4ToUtf(
- int ch, /* Unicode character to be stored in the
- * buffer. */
- char *buf) /* Buffer in which the UTF-8 representation of
- * the Unicode character is stored. Buffer must be
- * large enough to hold the UTF-8 character(s)
- * (at most 6 bytes). */
-{
-#if TCL_UTF_MAX <= 4
- if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
- /* Spit out a 4-byte UTF-8 character or 2 x 3-byte UTF-8 characters, depending on Tcl
- * version and/or TCL_UTF_MAX build value */
- int len = Tcl_UniCharToUtf(0xD800 | ((ch - 0x10000) >> 10), buf);
- return len + Tcl_UniCharToUtf(0xDC00 | (ch & 0x7FF), buf + len);
+const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *src, const Tcl_UniChar *ptr) {
+ if (src <= ptr + 1) {
+ return ptr;
}
-#endif
- if ((ch & ~0x7FF) == 0xD800) {
- buf[2] = (char) ((ch | 0x80) & 0xBF);
- buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
- buf[0] = (char) ((ch >> 12) | 0xE0);
- return 3;
- }
- if (ch == -1) {
- return 0;
+ if (((src[-1] & 0xFC00) == 0xDC00) && ((src[-2] & 0xFC00) == 0xD800)) {
+ return src - 2;
}
- return Tcl_UniCharToUtf(ch, buf);
+ return src - 1;
}
+
+
+#endif
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index a8bf795..73f5cf2 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -4,9 +4,9 @@
* This file contains utility functions that are used by many Tcl
* commands.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 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.
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
+#include "tclTomMath.h"
#include <math.h>
/*
@@ -105,14 +106,13 @@ static Tcl_ThreadDataKey precisionKey;
*/
static void ClearHash(Tcl_HashTable *tablePtr);
-static void FreeProcessGlobalValue(ClientData clientData);
-static void FreeThreadHash(ClientData clientData);
-static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue,
- int *indexPtr);
+static void FreeProcessGlobalValue(void *clientData);
+static void FreeThreadHash(void *clientData);
+static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ size_t endValue, Tcl_WideInt *indexPtr);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
-static int SetEndOffsetFromAny(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
+static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ size_t endValue, Tcl_WideInt *widePtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
@@ -121,16 +121,20 @@ static int FindElement(Tcl_Interp *interp, const char *string,
/*
* The following is the Tcl object type definition for an object that
* represents a list index in the form, "end-offset". It is used as a
- * performance optimization in TclGetIntForIndex. The internal rep is an
- * integer, so no memory management is required for it.
+ * performance optimization in Tcl_GetIntForIndex. The internal rep is
+ * stored directly in the wideValue, so no memory management is required
+ * for it. This is a caching internalrep, keeping the result of a parse
+ * around. This type is only created from a pre-existing string, so an
+ * updateStringProc will never be called and need not exist. The type
+ * is unregistered, so has no need of a setFromAnyProc either.
*/
-const Tcl_ObjType tclEndOffsetType = {
+static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfEndOffset, /* updateStringProc */
- SetEndOffsetFromAny
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
};
/*
@@ -371,10 +375,10 @@ const Tcl_ObjType tclEndOffsetType = {
*
* Given 'bytes' pointing to 'numBytes' bytes, scan through them and
* count the number of whitespace runs that could be list element
- * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
- * full list parser. Typically used to get a quick and dirty overestimate
- * of length size in order to allocate space for an actual list parser to
- * operate with.
+ * separators. If 'numBytes' is TCL_INDEX_NONE, scan to the terminating
+ * '\0'. Not a full list parser. Typically used to get a quick and dirty
+ * overestimate of length size in order to allocate space for an actual
+ * list parser to operate with.
*
* Results:
* Returns the largest number of list elements that could possibly be in
@@ -395,7 +399,7 @@ TclMaxListLength(
{
int count = 0;
- if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
+ if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
@@ -411,7 +415,7 @@ TclMaxListLength(
*/
while (numBytes) {
- if ((numBytes == -1) && (*bytes == '\0')) {
+ if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
@@ -422,9 +426,9 @@ TclMaxListLength(
count++;
do {
bytes++;
- numBytes -= (numBytes != -1);
+ numBytes -= (numBytes != TCL_INDEX_NONE);
} while (numBytes && TclIsSpaceProcM(*bytes));
- if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
+ if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
break;
}
@@ -433,7 +437,7 @@ TclMaxListLength(
*/
}
bytes++;
- numBytes -= (numBytes != -1);
+ numBytes -= (numBytes != TCL_INDEX_NONE);
}
/*
@@ -798,9 +802,11 @@ TclCopyAndCollapse(
char c = *src;
if (c == '\\') {
+ char buf[4] = "";
int numRead;
- int backslashCount = TclParseBackslash(src, count, &numRead, dst);
+ int backslashCount = TclParseBackslash(src, count, &numRead, buf);
+ memcpy(dst, buf, backslashCount);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
@@ -845,6 +851,7 @@ TclCopyAndCollapse(
*----------------------------------------------------------------------
*/
+#undef Tcl_SplitList
int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
@@ -867,7 +874,7 @@ Tcl_SplitList(
* string gets re-purposed to hold '\0' characters in the argv array.
*/
- size = TclMaxListLength(list, -1, &end) + 1;
+ size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1;
length = end - list;
argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1);
@@ -890,7 +897,7 @@ Tcl_SplitList(
ckfree(argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "internal error in Tcl_SplitList", -1));
+ "internal error in Tcl_SplitList", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
@@ -938,9 +945,9 @@ int
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
- * Tcl_ConvertCountedElement. */
+ * Tcl_ConvertCountedElement. */
{
- return Tcl_ScanCountedElement(src, -1, flagPtr);
+ return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr);
}
/*
@@ -951,8 +958,8 @@ Tcl_ScanElement(
* This function is a companion function to Tcl_ConvertCountedElement. It
* scans a string to see what needs to be done to it (e.g. add
* backslashes or enclosing braces) to make the string into a valid Tcl
- * list element. If length is -1, then the string is scanned from src up
- * to the first null byte.
+ * list element. If length is TCL_INDEX_NONE, then the string is scanned
+ * from src up to the first null byte.
*
* Results:
* The return value is an overestimate of the number of bytes that will
@@ -969,7 +976,7 @@ Tcl_ScanElement(
int
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
- int length, /* Number of bytes in src, or -1. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
@@ -988,7 +995,7 @@ Tcl_ScanCountedElement(
* This function is a companion function to TclConvertElement. It scans a
* string to see what needs to be done to it (e.g. add backslashes or
* enclosing braces) to make the string into a valid Tcl list element. If
- * length is -1, then the string is scanned from src up to the first null
+ * length is TCL_INDEX_NONE, then the string is scanned from src up to the first null
* byte. A NULL value for src is treated as an empty string. The incoming
* value of *flagPtr is a report from the caller what additional flags it
* will pass to TclConvertElement().
@@ -1010,10 +1017,10 @@ Tcl_ScanCountedElement(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
- int length, /* Number of bytes in src, or -1. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
@@ -1026,7 +1033,7 @@ TclScanElement(
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
- unsigned int bytesNeeded; /* Buffer length computed to complete the
+ TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
@@ -1034,7 +1041,7 @@ TclScanElement(
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
- if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
+ if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) {
/*
* Empty string element must be brace quoted.
*/
@@ -1117,7 +1124,7 @@ TclScanElement(
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
- if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
+ if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
@@ -1148,7 +1155,7 @@ TclScanElement(
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
@@ -1323,7 +1330,7 @@ Tcl_ConvertElement(
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
- return Tcl_ConvertCountedElement(src, -1, dst, flags);
+ return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags);
}
/*
@@ -1350,7 +1357,7 @@ Tcl_ConvertElement(
int
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
@@ -1383,7 +1390,7 @@ Tcl_ConvertCountedElement(
int
TclConvertElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
@@ -1402,10 +1409,10 @@ TclConvertElement(
* No matter what the caller demands, empty string must be braced!
*/
- if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = tclEmptyStringRep;
- length = 0;
- conversion = CONVERT_BRACE;
+ if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) {
+ p[0] = '{';
+ p[1] = '}';
+ return 2;
}
/*
@@ -1429,7 +1436,7 @@ TclConvertElement(
*/
if (conversion == CONVERT_NONE) {
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
@@ -1448,7 +1455,7 @@ TclConvertElement(
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
@@ -1521,7 +1528,7 @@ TclConvertElement(
p++;
continue;
case '\0':
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
return p - dst;
}
@@ -1597,7 +1604,7 @@ Tcl_Merge(
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
- bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
+ bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]);
if (bytesNeeded > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
@@ -1615,7 +1622,7 @@ Tcl_Merge(
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
- dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
+ dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
@@ -1627,6 +1634,7 @@ Tcl_Merge(
return result;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -1660,6 +1668,7 @@ Tcl_Backslash(
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1705,10 +1714,7 @@ TclTrimRight(
const char *q = trim;
int pInc = 0, bytesLeft = numTrim;
- pp = TclUtfPrev(p, bytes);
-#if TCL_UTF_MAX < 4
- pp = TclUtfPrev(pp, bytes);
-#endif
+ pp = Tcl_UtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
@@ -2018,7 +2024,7 @@ Tcl_ConcatObj(
if (TclListObjIsCanonical(objPtr)) {
continue;
}
- Tcl_GetStringFromObj(objPtr, &length);
+ TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
@@ -2027,7 +2033,7 @@ Tcl_ConcatObj(
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- if (objPtr->bytes && objPtr->length == 0) {
+ if (!TclListObjIsCanonical(objPtr)) {
continue;
}
if (resPtr) {
@@ -2114,6 +2120,7 @@ Tcl_ConcatObj(
return resPtr;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -2132,6 +2139,7 @@ Tcl_ConcatObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_StringMatch
int
Tcl_StringMatch(
const char *str, /* String. */
@@ -2140,7 +2148,7 @@ Tcl_StringMatch(
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
-
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
@@ -2214,7 +2222,7 @@ Tcl_StringCaseMatch(
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
- ch2 = TclUCS4ToLower(ch2);
+ ch2 = Tcl_UniCharToLower(ch2);
}
}
@@ -2229,7 +2237,7 @@ Tcl_StringCaseMatch(
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
- if (ch2==ch1 || ch2==TclUCS4ToLower(ch1)) {
+ if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
@@ -2288,7 +2296,7 @@ Tcl_StringCaseMatch(
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
- ch1 = TclUCS4ToLower(ch1);
+ ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
@@ -2302,7 +2310,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
- startChar = TclUCS4ToLower(startChar);
+ startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
@@ -2317,7 +2325,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
- endChar = TclUCS4ToLower(endChar);
+ endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
@@ -2366,7 +2374,7 @@ Tcl_StringCaseMatch(
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
- if (TclUCS4ToLower(ch1) != TclUCS4ToLower(ch2)) {
+ if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
@@ -2403,7 +2411,7 @@ TclByteArrayMatch(
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
@@ -2588,11 +2596,11 @@ TclStringMatchObj(
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
- if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) {
+ if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
- udata = Tcl_GetUnicodeFromObj(strObj, &length);
- uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
+ udata = TclGetUnicodeFromObj_(strObj, &length);
+ uptn = TclGetUnicodeFromObj_(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
} else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj)
&& !flags) {
@@ -2657,8 +2665,8 @@ Tcl_DStringInit(
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
- const char *bytes, /* String to append. If length is -1 then this
- * must be null-terminated. */
+ const char *bytes, /* String to append. If length is
+ * < 0 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. */
@@ -2684,18 +2692,18 @@ Tcl_DStringAppend(
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
- int offset = -1;
+ int index = TCL_INDEX_NONE;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
- offset = bytes - dsPtr->string;
+ index = bytes - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
- if (offset >= 0) {
- bytes = dsPtr->string + offset;
+ if (index >= 0) {
+ bytes = dsPtr->string + index;
}
}
}
@@ -2727,7 +2735,7 @@ TclDStringAppendObj(
Tcl_Obj *objPtr)
{
int length;
- char *bytes = Tcl_GetStringFromObj(objPtr, &length);
+ char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
@@ -2794,7 +2802,7 @@ Tcl_DStringAppendElement(
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
- newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
+ newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags);
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
@@ -2843,7 +2851,7 @@ Tcl_DStringAppendElement(
dsPtr->length++;
}
- dsPtr->length += TclConvertElement(element, -1, dst, flags);
+ dsPtr->length += TclConvertElement(element, TCL_INDEX_NONE, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
@@ -2965,8 +2973,7 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(dsPtr));
}
/*
@@ -2995,6 +3002,14 @@ Tcl_DStringGetResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+ Tcl_Obj *obj = Tcl_GetObjResult(interp);
+ const char *bytes = TclGetString(obj);
+
+ Tcl_DStringFree(dsPtr);
+ Tcl_DStringAppend(dsPtr, bytes, obj->length);
+ Tcl_ResetResult(interp);
+#else
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
@@ -3018,7 +3033,7 @@ Tcl_DStringGetResult(
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
- if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
+ if (iPtr->objResultPtr->bytes == &tclEmptyString) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
@@ -3027,8 +3042,8 @@ Tcl_DStringGetResult(
dsPtr->string = TclGetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
- TclFreeIntRep(iPtr->objResultPtr);
- iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ TclFreeInternalRep(iPtr->objResultPtr);
+ iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
@@ -3066,12 +3081,13 @@ Tcl_DStringGetResult(
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
}
/*
*----------------------------------------------------------------------
*
- * TclDStringToObj --
+ * Tcl_DStringToObj --
*
* This function moves a dynamic string's contents to a new Tcl_Obj. Be
* aware that this function does *not* check that the encoding of the
@@ -3091,7 +3107,7 @@ Tcl_DStringGetResult(
*/
Tcl_Obj *
-TclDStringToObj(
+Tcl_DStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
@@ -3204,9 +3220,7 @@ Tcl_DStringEndSublist(
void
Tcl_PrintDouble(
- Tcl_Interp *interp, /* Interpreter whose tcl_precision variable
- * used to be used to control printing. It's
- * ignored now. */
+ TCL_UNUSED(Tcl_Interp *),
double value, /* Value to print as string. */
char *dst) /* Where to store converted value; must have
* at least TCL_DOUBLE_SPACE characters. */
@@ -3222,7 +3236,7 @@ Tcl_PrintDouble(
* Handle NaN.
*/
- if (TclIsNaN(value)) {
+ if (isnan(value)) {
TclFormatNaN(value, dst);
return;
}
@@ -3231,7 +3245,7 @@ Tcl_PrintDouble(
* Handle infinities.
*/
- if (TclIsInfinite(value)) {
+ if (isinf(value)) {
/*
* Remember to copy the terminating NUL too.
*/
@@ -3249,7 +3263,7 @@ Tcl_PrintDouble(
*/
if (*precisionPtr == 0) {
- digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
+ digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST,
&exponent, &signum, &end);
} else {
/*
@@ -3286,13 +3300,13 @@ Tcl_PrintDouble(
* 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
+ * Uncomment TCL_DD_SHORTEST 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 */,
+ TCL_DD_E_FORMAT /* | TCL_DD_SHORTEST */,
&exponent, &signum, &end);
}
if (signum) {
@@ -3378,16 +3392,17 @@ Tcl_PrintDouble(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *
TclPrecTraceProc(
- ClientData clientData, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
Tcl_Obj *value;
- int prec;
+ Tcl_WideInt prec;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
@@ -3411,7 +3426,7 @@ TclPrecTraceProc(
if (flags & TCL_TRACE_READS) {
- Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr),
+ Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr),
flags & TCL_GLOBAL_ONLY);
return NULL;
}
@@ -3427,13 +3442,14 @@ TclPrecTraceProc(
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL
- || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK
+ || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK
|| prec < 0 || prec > TCL_MAX_PREC) {
return (char *) "improper value for precision";
}
- *precisionPtr = prec;
+ *precisionPtr = (int)prec;
return NULL;
}
+#endif /* !TCL_NO_DEPRECATED)*/
/*
*----------------------------------------------------------------------
@@ -3557,9 +3573,9 @@ int
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
- long n) /* The integer to format. */
+ Tcl_WideInt n) /* The integer to format. */
{
- unsigned long intVal;
+ Tcl_WideUInt intVal;
int i = 0;
int numFormatted, j;
static const char digits[] = "0123456789";
@@ -3568,7 +3584,7 @@ TclFormatInt(
* Generate the characters of the result backwards in the buffer.
*/
- intVal = (n < 0 ? -(unsigned long)n : (unsigned long)n);
+ intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n);
do {
buffer[i++] = digits[intVal % 10];
intVal = intVal / 10;
@@ -3595,7 +3611,67 @@ TclFormatInt(
/*
*----------------------------------------------------------------------
*
- * TclGetIntForIndex --
+ * GetWideForIndex --
+ *
+ * This function produces a wide integer value corresponding to the
+ * index value held in *objPtr. The parsing supports all values
+ * recognized as any size of integer, and the syntaxes end[-+]$integer
+ * and $integer[-+]$integer. The argument endValue is used to give
+ * the meaning of the literal index value "end". Index arithmetic
+ * on arguments outside the wide integer range are only accepted
+ * when interp is a working interpreter, not NULL.
+ *
+ * Results:
+ * When parsing of *objPtr successfully recognizes an index value,
+ * TCL_OK is returned, and the wide integer value corresponding to
+ * the recognized index value is written to *widePtr. When parsing
+ * fails, TCL_ERROR is returned and error information is written to
+ * interp, if non-NULL.
+ *
+ * Side effects:
+ * The type of *objPtr may change.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWideForIndex(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ Tcl_Obj *objPtr, /* Points to the value to be parsed */
+ size_t endValue, /* The value to be stored at *widePtr if
+ * objPtr holds "end".
+ * NOTE: this value may be TCL_INDEX_NONE. */
+ Tcl_WideInt *widePtr) /* Location filled in with a wide integer
+ * representing an index. */
+{
+ int numType;
+ void *cd;
+ int code = Tcl_GetNumberFromObj(NULL, objPtr, &cd, &numType);
+
+ if (code == TCL_OK) {
+ if (numType == TCL_NUMBER_INT) {
+ /* objPtr holds an integer in the signed wide range */
+ *widePtr = *(Tcl_WideInt *)cd;
+ return TCL_OK;
+ }
+ if (numType == TCL_NUMBER_BIG) {
+ /* objPtr holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX);
+ return TCL_OK;
+ }
+ }
+
+ /* objPtr does not hold a number, check the end+/- format... */
+ return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetIntForIndex --
*
* Provides an integer corresponding to the list index held in a Tcl
* object. The string value 'objPtr' is expected have the format
@@ -3622,7 +3698,7 @@ TclFormatInt(
*/
int
-TclGetIntForIndex(
+Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
@@ -3631,124 +3707,44 @@ TclGetIntForIndex(
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
- * representing an index. */
+ * representing an index. May be NULL.*/
{
- int length;
- char *opPtr;
- const char *bytes;
-
- if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
-
- if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
-
- bytes = TclGetStringFromObj(objPtr, &length);
+ Tcl_WideInt wide;
- /*
- * Leading whitespace is acceptable in an index.
- */
-
- while (length && TclIsSpaceProcM(*bytes)) {
- bytes++;
- length--;
+ if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
+ return TCL_ERROR;
}
-
- if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr,
- TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
- int code, first, second;
- char savedOp = *opPtr;
-
- if ((savedOp != '+') && (savedOp != '-')) {
- goto parseError;
- }
- if (TclIsSpaceProcM(opPtr[1])) {
- goto parseError;
- }
- *opPtr = '\0';
- code = Tcl_GetInt(interp, bytes, &first);
- *opPtr = savedOp;
- if (code == TCL_ERROR) {
- goto parseError;
- }
- if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) {
- goto parseError;
- }
- if (savedOp == '+') {
- *indexPtr = first + second;
+ if (indexPtr != NULL) {
+ if ((wide < 0) && (endValue >= 0)) {
+ *indexPtr = TCL_INDEX_NONE;
+ } else if (wide > INT_MAX) {
+ *indexPtr = INT_MAX;
+ } else if (wide < INT_MIN) {
+ *indexPtr = INT_MIN;
} else {
- *indexPtr = first - second;
+ *indexPtr = (int) wide;
}
- return TCL_OK;
}
-
- /*
- * Report a parse error.
- */
-
- parseError:
- if (interp != NULL) {
- bytes = TclGetString(objPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be integer?[+-]integer? or"
- " end?[+-]integer?", bytes));
- if (!strncmp(bytes, "end-", 4)) {
- bytes += 4;
- }
- TclCheckBadOctal(interp, bytes);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
- }
-
- return TCL_ERROR;
+ return TCL_OK;
}
-
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfEndOffset --
- *
- * Update the string rep of a Tcl object holding an "end-offset"
- * expression.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Stores a valid string in the object's string rep.
- *
- * This function does NOT free any earlier string rep. If it is called on an
- * object that already has a valid string rep, it will leak memory.
+ * GetEndOffsetFromObj --
*
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfEndOffset(
- Tcl_Obj *objPtr)
-{
- char buffer[TCL_INTEGER_SPACE + 5];
- int len = 3;
-
- memcpy(buffer, "end", 4);
- if (objPtr->internalRep.longValue != 0) {
- buffer[len++] = '-';
- len += TclFormatInt(buffer+len,
- (long)(-(unsigned long)(objPtr->internalRep.longValue)));
- }
- objPtr->bytes = (char *)ckalloc(len+1);
- memcpy(objPtr->bytes, buffer, len+1);
- objPtr->length = len;
-}
-
-/*
- *----------------------------------------------------------------------
+ * Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
+ * convert it to an internal representation.
*
- * GetEndOffsetFromObj --
+ * The internal representation (wideValue) uses the following encoding:
*
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
+ * WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
+ * WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
+ * -$n: Index "end-[expr {$n-1}]"
+ * -2: Index "end-1"
+ * -1: Index "end"
+ * 0: Index "0"
+ * WIDE_MAX-1: Index "end+n", for any n > 1
+ * WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
@@ -3761,118 +3757,239 @@ UpdateStringOfEndOffset(
static int
GetEndOffsetFromObj(
+ Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
- int endValue, /* The value to be stored at "indexPtr" if
+ size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
- int *indexPtr) /* Location filled in with an integer
+ Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
- if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
+ Tcl_ObjInternalRep *irPtr;
+ Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
+ void *cd;
- /* TODO: Handle overflow cases sensibly */
- *indexPtr = endValue + (int)objPtr->internalRep.longValue;
- return TCL_OK;
-}
+ while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
+ Tcl_ObjInternalRep ir;
+ int length;
+ const char *bytes = TclGetStringFromObj(objPtr, &length);
+ if (*bytes != 'e') {
+ int numType;
+ const char *opPtr;
+ int t1 = 0, t2 = 0;
-/*
- *----------------------------------------------------------------------
- *
- * SetEndOffsetFromAny --
- *
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
- *
- * Results:
- * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
- *
- * Side effects:
- * If interp is not NULL, stores an error message in the interpreter
- * result.
- *
- *----------------------------------------------------------------------
- */
+ /* Value doesn't start with "e" */
-static int
-SetEndOffsetFromAny(
- Tcl_Interp *interp, /* Tcl interpreter or NULL */
- Tcl_Obj *objPtr) /* Pointer to the object to parse */
-{
- int offset; /* Offset in the "end-offset" expression */
- const char *bytes; /* String rep of the object */
- int length; /* Length of the object's string rep */
+ /* If we reach here, the string rep of objPtr exists. */
- /*
- * If it's already the right type, we're fine.
- */
+ /*
+ * The valid index syntax does not include any value that is
+ * a list of more than one element. This is necessary so that
+ * lists of index values can be reliably distinguished from any
+ * single index value.
+ */
- if (objPtr->typePtr == &tclEndOffsetType) {
- return TCL_OK;
- }
+ /*
+ * Quick scan to see if multi-value list is even possible.
+ * This relies on TclGetString() returning a NUL-terminated string.
+ */
+ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
- /*
- * Check for a string rep of the right form.
- */
+ /* If it's possible, do the full list parse. */
+ && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length))
+ && (length > 1)) {
+ goto parseError;
+ }
- bytes = TclGetStringFromObj(objPtr, &length);
- if ((*bytes != 'e') || (strncmp(bytes, "end",
- (size_t)((length > 3) ? 3 : length)) != 0)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
- }
- return TCL_ERROR;
- }
+ /* Passed the list screen, so parse for index arithmetic expression */
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr,
+ TCL_PARSE_INTEGER_ONLY)) {
+ Tcl_WideInt w1=0, w2=0;
- /*
- * Convert the string rep.
- */
+ /* value starts with valid integer... */
- if (length <= 3) {
- offset = 0;
- } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
- /*
- * This is our limited string expression evaluator. Pass everything
- * after "end-" to Tcl_GetInt, then reverse for offset.
- */
+ if ((*opPtr == '-') || (*opPtr == '+')) {
+ /* ... value continues with [-+] ... */
- if (TclIsSpaceProcM(bytes[4])) {
- goto badIndexFormat;
- }
- if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
- return TCL_ERROR;
+ /* Save first integer as wide if possible */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t1);
+ if (t1 == TCL_NUMBER_INT) {
+ w1 = (*(Tcl_WideInt *)cd);
+ }
+
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
+ TCL_INDEX_NONE, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* ... value concludes with second valid integer */
+
+ /* Save second integer as wide if possible */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t2);
+ if (t2 == TCL_NUMBER_INT) {
+ w2 = (*(Tcl_WideInt *)cd);
+ }
+ }
+ }
+ /* Clear invalid internalreps left by TclParseNumber */
+ TclFreeInternalRep(objPtr);
+
+ if (t1 && t2) {
+ /* We have both integer values */
+ if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
+ /* Both are wide, do wide-integer math */
+ if (*opPtr == '-') {
+ if (w2 == WIDE_MIN) {
+ goto extreme;
+ }
+ w2 = -w2;
+ }
+
+ if ((w1 ^ w2) < 0) {
+ /* Different signs, sum cannot overflow */
+ offset = w1 + w2;
+ } else if (w1 >= 0) {
+ if (w1 < WIDE_MAX - w2) {
+ offset = w1 + w2;
+ } else {
+ offset = WIDE_MAX;
+ }
+ } else {
+ if (w1 > WIDE_MIN - w2) {
+ offset = w1 + w2;
+ } else {
+ offset = WIDE_MIN;
+ }
+ }
+ } else {
+ /*
+ * At least one is big, do bignum math. Little reason to
+ * value performance here. Re-use code. Parse has verified
+ * objPtr is an expression. Compute it.
+ */
+
+ Tcl_Obj *sum;
+
+ extreme:
+ if (interp) {
+ Tcl_ExprObj(interp, objPtr, &sum);
+ } else {
+ Tcl_Interp *compute = Tcl_CreateInterp();
+ Tcl_ExprObj(compute, objPtr, &sum);
+ Tcl_DeleteInterp(compute);
+ }
+ Tcl_GetNumberFromObj(NULL, sum, &cd, &numType);
+
+ if (numType == TCL_NUMBER_INT) {
+ /* sum holds an integer in the signed wide range */
+ offset = *(Tcl_WideInt *)cd;
+ } else {
+ /* sum holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ offset = WIDE_MIN;
+ } else {
+ offset = WIDE_MAX;
+ }
+ }
+ Tcl_DecrRefCount(sum);
+ }
+ if (offset < 0) {
+ offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1;
+ }
+ goto parseOK;
+ }
+ }
+ goto parseError;
}
- if (bytes[3] == '-') {
- offset = (int)(-(unsigned int)offset);
+ if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
+ /* Doesn't start with "end" */
+ goto parseError;
}
- } else {
- /*
- * Conversion failed. Report the error.
- */
+ if (length > 4) {
+ int t;
+
+ /* Parse for the "end-..." or "end+..." formats */
- badIndexFormat:
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ if ((bytes[3] != '-') && (bytes[3] != '+')) {
+ /* No operator where we need one */
+ goto parseError;
+ }
+ if (TclIsSpaceProc(bytes[4])) {
+ /* Space after + or - not permitted. */
+ goto parseError;
+ }
+
+ /* Parse the integer offset */
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
+ bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* Not a recognized integer format */
+ goto parseError;
+ }
+
+ /* Got an integer offset; pull it from where parser left it. */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t);
+
+ if (t == TCL_NUMBER_BIG) {
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
+ } else {
+ offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
+ }
+ } else {
+ /* assert (t == TCL_NUMBER_INT); */
+ offset = (*(Tcl_WideInt *)cd);
+ if (bytes[3] == '-') {
+ offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
+ }
+ if (offset == 1) {
+ offset = WIDE_MAX; /* "end+1" */
+ } else if (offset > 1) {
+ offset = WIDE_MAX - 1; /* "end+n", out of range */
+ } else if (offset != WIDE_MIN) {
+ offset--;
+ }
+ }
}
- return TCL_ERROR;
+
+ parseOK:
+ /* Success. Store the new internal rep. */
+ ir.wideValue = offset;
+ Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir);
}
- /*
- * The conversion succeeded. Free the old internal rep and set the new
- * one.
- */
+ offset = irPtr->wideValue;
+
+ if (offset == WIDE_MAX) {
+ *widePtr = endValue + 1;
+ } else if (offset == WIDE_MIN) {
+ *widePtr = -1;
+ } else if (endValue == (size_t)-1) {
+ *widePtr = offset;
+ } else if (offset < 0) {
+ /* Different signs, sum cannot overflow */
+ *widePtr = endValue + offset + 1;
+ } else if (offset < WIDE_MAX) {
+ *widePtr = offset;
+ } else {
+ *widePtr = WIDE_MAX;
+ }
+ return TCL_OK;
- TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = offset;
- objPtr->typePtr = &tclEndOffsetType;
+ /* Report a parse error. */
+ parseError:
+ if (interp != NULL) {
+ char * bytes = TclGetString(objPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be integer?[+-]integer? or"
+ " end?[+-]integer?", bytes));
+ if (!strncmp(bytes, "end-", 4)) {
+ bytes += 4;
+ }
+ TclCheckBadOctal(interp, bytes);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ }
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -3887,7 +4004,7 @@ SetEndOffsetFromAny(
* arithmetic expressions. The absolute index values that can be
* directly meaningful as an index into either a list or a string are
* those integer values >= TCL_INDEX_START (0)
- * and < TCL_INDEX_AFTER (INT_MAX).
+ * and < INT_MAX.
* The largest string supported in Tcl 8 has bytelength INT_MAX.
* This means the largest supported character length is also INT_MAX,
* and the index of the last character in a string of length INT_MAX
@@ -3896,9 +4013,9 @@ SetEndOffsetFromAny(
* Any absolute index value parsed outside that range is encoded
* using the before and after values passed in by the
* caller as the encoding to use for indices that are either
- * less than or greater than the usable index range. TCL_INDEX_AFTER
+ * less than or greater than the usable index range. TCL_INDEX_NONE
* is available as a good choice for most callers to use for
- * after. Likewise, the value TCL_INDEX_BEFORE is good for
+ * after. Likewise, the value TCL_INDEX_NONE is good for
* most callers to use for before. Other values are possible
* when the caller knows it is helpful in producing its own behavior
* for indices before and after the indexed item.
@@ -3938,47 +4055,32 @@ TclIndexEncode(
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
+ Tcl_WideInt wide;
int idx;
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) {
- /* We parsed a value in the range INT_MIN...INT_MAX */
- integerEncode:
- if (idx < TCL_INDEX_START) {
- /* All negative absolute indices are "before the beginning" */
- idx = before;
- } else if (idx == INT_MAX) {
- /* This index value is always "after the end" */
- idx = after;
- }
- /* usual case, the absolute index value encodes itself */
- } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
- /*
- * We parsed an end+offset index value.
- * idx holds the offset value in the range INT_MIN...INT_MAX.
- */
- if (idx > 0) {
- /*
- * All end+postive or end-negative expressions
- * always indicate "after the end".
- */
- idx = after;
- } else if (idx < INT_MIN - TCL_INDEX_END) {
- /* These indices always indicate "before the beginning */
- idx = before;
- } else {
- /* Encoded end-positive (or end+negative) are offset */
- idx += TCL_INDEX_END;
- }
-
- /* TODO: Consider flag to suppress repeated end-offset parse. */
- } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) {
- /*
- * Only reach this case when the index value is a
- * constant index arithmetic expression, and idx
- * holds the result. Treat it the same as if it were
- * parsed as an absolute integer value.
- */
- goto integerEncode;
+ if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType);
+ if (irPtr && irPtr->wideValue >= 0) {
+ /* "int[+-]int" syntax, works the same here as "int" */
+ irPtr = NULL;
+ }
+ /*
+ * We parsed an end+offset index value.
+ * wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
+ */
+ if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
+ /*
+ * All end+postive or end-negative expressions
+ * always indicate "after the end".
+ */
+ idx = after;
+ } else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) {
+ /* These indices always indicate "before the beginning */
+ idx = before;
+ } else {
+ /* Encoded end-positive (or end+negative) are offset */
+ idx = (int)wide;
+ }
} else {
return TCL_ERROR;
}
@@ -4006,10 +4108,14 @@ TclIndexDecode(
int encoded, /* Value to decode */
int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
{
- if (encoded <= TCL_INDEX_END) {
- return (encoded - TCL_INDEX_END) + endValue;
+ if (encoded > TCL_INDEX_END) {
+ return encoded;
+ }
+ endValue += encoded - TCL_INDEX_END;
+ if (endValue >= 0) {
+ return endValue;
}
- return encoded;
+ return TCL_INDEX_NONE;
}
/*
@@ -4071,7 +4177,7 @@ TclCheckBadOctal(
*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- " (looks like invalid octal number)", -1);
+ " (looks like invalid octal number)", TCL_INDEX_NONE);
}
return 1;
}
@@ -4154,7 +4260,7 @@ GetThreadHash(
static void
FreeThreadHash(
- ClientData clientData)
+ void *clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
@@ -4176,7 +4282,7 @@ FreeThreadHash(
static void
FreeProcessGlobalValue(
- ClientData clientData)
+ void *clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
@@ -4225,7 +4331,8 @@ TclSetProcessGlobalValue(
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
- bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
+ bytes = TclGetString(newValue);
+ pgvPtr->numBytes = newValue->length;
pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
@@ -4418,11 +4525,10 @@ TclGetObjNameOfExecutable(void)
const char *
Tcl_GetNameOfExecutable(void)
{
- int numBytes;
- const char *bytes =
- Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes);
+ Tcl_Obj *obj = TclGetObjNameOfExecutable();
+ const char *bytes = TclGetString(obj);
- if (numBytes == 0) {
+ if (obj->length == 0) {
return NULL;
}
return bytes;
@@ -4693,7 +4799,7 @@ TclReToGlob(
invalidGlob:
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 6f0ec89..c614371 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -7,11 +7,11 @@
* The implementation of arrays is modelled after an initial
* implementation by Mark Diekhans and Karl Lehenbauer.
*
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Miguel Sofer
+ * Copyright © 1987-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Miguel Sofer
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -45,7 +45,7 @@ static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* NOTE: VarHashCreateVar increments the recount of its key argument.
@@ -60,8 +60,7 @@ VarHashCreateVar(
Tcl_Obj *key,
int *newPtr)
{
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
- key, newPtr);
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr);
if (!hPtr) {
return NULL;
@@ -146,6 +145,7 @@ static const char ISARRAYELEMENT[] =
*/
typedef struct ArraySearch {
+ Tcl_Obj *name; /* Name of this search */
int id; /* Integer id used to distinguish among
* multiple concurrent searches for the same
* array. */
@@ -165,11 +165,30 @@ typedef struct ArraySearch {
} ArraySearch;
/*
+ * TIP #508: [array default]
+ *
+ * The following structure extends the regular TclVarHashTable used by array
+ * variables to store their optional default value.
+ */
+
+typedef struct ArrayVarHashTable {
+ TclVarHashTable table;
+ Tcl_Obj *defaultObj;
+} ArrayVarHashTable;
+
+/*
* Forward references to functions defined later in this file:
*/
static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *patternPtr, int includeLinks);
+static void ArrayPopulateSearch(Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, Var *varPtr,
+ ArraySearch *searchPtr);
+static void ArrayDoneSearch(Interp *iPtr, Var *varPtr,
+ ArraySearch *searchPtr);
+static Tcl_NRPostProc ArrayForLoopCallback;
+static Tcl_ObjCmdProc ArrayForNRCmd;
static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
Var *varPtr, int flags, int index);
@@ -188,8 +207,14 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags, int index);
-static int SetArraySearchObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
+
+/*
+ * TIP #508: [array default]
+ */
+
+static Tcl_ObjCmdProc ArrayDefaultCmd;
+static void DeleteArrayVar(Var *arrayPtr);
+static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj);
/*
* Functions defined in this file that may be exported in the future for use
@@ -202,14 +227,9 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp,
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeLocalVarName;
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
-static Tcl_UpdateStringProc UpdateParsedVarName;
-
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
-static Tcl_SetFromAnyProc PanicOnSetVarName;
/*
* Types of Tcl_Objs used to cache variable lookups.
@@ -228,30 +248,52 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
static const Tcl_ObjType localVarNameType = {
"localVarName",
- FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
+ FreeLocalVarName, DupLocalVarName, NULL, NULL
};
-static const Tcl_ObjType tclParsedVarNameType = {
+#define LocalSetInternalRep(objPtr, index, namePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ Tcl_Obj *ptr = (namePtr); \
+ if (ptr) {Tcl_IncrRefCount(ptr);} \
+ ir.twoPtrValue.ptr1 = ptr; \
+ ir.twoPtrValue.ptr2 = INT2PTR(index); \
+ Tcl_StoreInternalRep((objPtr), &localVarNameType, &ir); \
+ } while (0)
+
+#define LocalGetInternalRep(objPtr, index, name) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
+ (name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \
+ } while (0)
+
+static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
- FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
+ FreeParsedVarName, DupParsedVarName, NULL, NULL
};
-/*
- * Type of Tcl_Objs used to speed up array searches.
- *
- * INTERNALREP DEFINITION:
- * twoPtrValue.ptr1: searchIdNumber (cast to pointer)
- * twoPtrValue.ptr2: variableNameStartInString (cast to pointer)
- *
- * Note that the value stored in ptr2 is the offset into the string of the
- * start of the variable name and not the address of the variable name itself,
- * as this can be safely copied.
- */
-
-const Tcl_ObjType tclArraySearchType = {
- "array search",
- NULL, NULL, NULL, SetArraySearchObj
-};
+#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ Tcl_Obj *ptr1 = (arrayPtr); \
+ Tcl_Obj *ptr2 = (elem); \
+ if (ptr1) {Tcl_IncrRefCount(ptr1);} \
+ if (ptr2) {Tcl_IncrRefCount(ptr2);} \
+ ir.twoPtrValue.ptr1 = ptr1; \
+ ir.twoPtrValue.ptr2 = ptr2; \
+ Tcl_StoreInternalRep((objPtr), &parsedVarNameType, &ir); \
+ } while (0)
+
+#define ParsedGetInternalRep(objPtr, parsed, array, elem) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &parsedVarNameType); \
+ (parsed) = (irPtr != NULL); \
+ (array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
Var *
TclVarHashCreateVar(
@@ -474,9 +516,8 @@ TclLookupVar(
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
- * are 1. The object part1Ptr is converted to one of localVarNameType,
- * tclNsVarNameType or tclParsedVarNameType and caches as much of the
- * lookup as it can.
+ * are 1. The object part1Ptr is converted to one of localVarNameType
+ * or parsedVarNameType and caches as much of the lookup as it can.
* When createPart1 is 1, callers must IncrRefCount part1Ptr if they
* plan to DecrRefCount it.
*
@@ -558,24 +599,20 @@ TclObjLookupVarEx(
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
- const char *part1;
- int index, len1, len2;
- int parsed = 0;
- Tcl_Obj *objPtr;
- const Tcl_ObjType *typePtr = part1Ptr->typePtr;
const char *errMsg = NULL;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
- char *newPart2 = NULL;
- *arrayPtrPtr = NULL;
+ int index, parsed = 0;
- if (typePtr == &localVarNameType) {
- int localIndex;
+ int localIndex;
+ Tcl_Obj *namePtr, *arrayPtr, *elem;
- localVarNameTypeHandling:
- localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
+ *arrayPtrPtr = NULL;
+
+ restart:
+ LocalGetInternalRep(part1Ptr, localIndex, namePtr);
+ if (localIndex >= 0) {
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
@@ -583,8 +620,7 @@ TclObjLookupVarEx(
* Use the cached index if the names coincide.
*/
- Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);
+ Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
(namePtr && (checkNamePtr == namePtr))) {
@@ -596,12 +632,11 @@ TclObjLookupVarEx(
}
/*
- * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
- * parts.
+ * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts.
*/
- if (typePtr == &tclParsedVarNameType) {
- if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
+ ParsedGetInternalRep(part1Ptr, parsed, arrayPtr, elem);
+ if (parsed && arrayPtr) {
if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
@@ -615,33 +650,23 @@ TclObjLookupVarEx(
}
return NULL;
}
- part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
- if (newPart2) {
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
- }
- part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
- typePtr = part1Ptr->typePtr;
- if (typePtr == &localVarNameType) {
- goto localVarNameTypeHandling;
- }
- }
- parsed = 1;
+ part2Ptr = elem;
+ part1Ptr = arrayPtr;
+ goto restart;
}
- part1 = TclGetStringFromObj(part1Ptr, &len1);
- if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) {
+ if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
- int i;
+ int len;
+ const char *part1 = TclGetStringFromObj(part1Ptr, &len);
+
+ if ((len > 1) && (part1[len - 1] == ')')) {
+ const char *part2 = strchr(part1, '(');
- len2 = -1;
- for (i = 0; i < len1; i++) {
- if (*(part1 + i) == '(') {
+ if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
@@ -652,49 +677,13 @@ TclObjLookupVarEx(
return NULL;
}
- /*
- * part1Ptr points to an array element; first copy the element
- * name to a new string part2.
- */
+ arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
+ part2Ptr = Tcl_NewStringObj(part2 + 1,
+ len - (part2 - part1) - 2);
- part2 = part1 + i + 1;
- len2 = len1 - i - 2;
- len1 = i;
-
- newPart2 = ckalloc(len2 + 1);
- memcpy(newPart2, part2, len2);
- *(newPart2+len2) = '\0';
- part2 = newPart2;
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
+ ParsedSetInternalRep(part1Ptr, arrayPtr, part2Ptr);
- /*
- * Free the internal rep of the original part1Ptr, now renamed
- * objPtr, and set it to tclParsedVarNameType.
- */
-
- objPtr = part1Ptr;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclParsedVarNameType;
-
- /*
- * Define a new string object to hold the new part1Ptr, i.e.,
- * the array name. Set the internal rep of objPtr, reset
- * typePtr and part1 to contain the references to the array
- * name.
- */
-
- TclNewStringObj(part1Ptr, part1, len1);
- Tcl_IncrRefCount(part1Ptr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr;
- objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2;
-
- typePtr = part1Ptr->typePtr;
- part1 = TclGetString(part1Ptr);
- break;
+ part1Ptr = arrayPtr;
}
}
}
@@ -705,8 +694,6 @@ TclObjLookupVarEx(
* the cached types if possible.
*/
- TclFreeIntRep(part1Ptr);
-
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
@@ -715,9 +702,6 @@ TclObjLookupVarEx(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(part1Ptr), NULL);
}
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
return NULL;
}
@@ -729,28 +713,46 @@ TclObjLookupVarEx(
/*
* An indexed local variable.
*/
- Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index);
-
- part1Ptr->typePtr = &localVarNameType;
- if (part1Ptr != cachedNamePtr) {
- part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr;
- Tcl_IncrRefCount(cachedNamePtr);
- if (cachedNamePtr->typePtr != &localVarNameType
- || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) {
- TclFreeIntRep(cachedNamePtr);
- }
+
+ Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
+
+ if (part1Ptr == cachedNamePtr) {
+ LocalSetInternalRep(part1Ptr, index, NULL);
} else {
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
+ /*
+ * [80304238ac] Trickiness here. We will store and incr the
+ * refcount on cachedNamePtr. Trouble is that it's possible
+ * (see test var-22.1) for cachedNamePtr to have an internalrep
+ * that contains a stored and refcounted part1Ptr. This
+ * would be a reference cycle which leads to a memory leak.
+ *
+ * The solution here is to wipe away all internalrep(s) in
+ * cachedNamePtr and leave it as string only. This is
+ * radical and destructive, so a better idea would be welcome.
+ */
+
+ /*
+ * Firstly set cached local var reference (avoid free before set,
+ * see [45b9faf103f2])
+ */
+ LocalSetInternalRep(part1Ptr, index, cachedNamePtr);
+
+ /* Then wipe it */
+ TclFreeInternalRep(cachedNamePtr);
+
+ /*
+ * Now go ahead and convert it the the "localVarName" type,
+ * since we suspect at least some use of the value as a
+ * varname and we want to resolve it quickly.
+ */
+ LocalSetInternalRep(cachedNamePtr, index, NULL);
}
- part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index);
} else {
/*
* At least mark part1Ptr as already parsed.
*/
- part1Ptr->typePtr = &tclParsedVarNameType;
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
- part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
+ ParsedSetInternalRep(part1Ptr, NULL, NULL);
}
donePart1:
@@ -766,9 +768,6 @@ TclObjLookupVarEx(
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
createPart1, createPart2, varPtr, -1);
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
}
return varPtr;
}
@@ -935,38 +934,41 @@ TclLookupSimpleVar(
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
- if (create) { /* Var wasn't found so create it. */
- TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
- flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
- if (varNsPtr == NULL) {
- *errMsgPtr = BADNAMESPACE;
- return NULL;
- } else if (tail == NULL) {
- *errMsgPtr = MISSINGNAME;
- return NULL;
- }
- if (tail != varName) {
- tailPtr = Tcl_NewStringObj(tail, -1);
- } else {
- tailPtr = varNamePtr;
- }
- varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr,
- &isNew);
- if (lookGlobal) {
- /*
- * The variable was created starting from the global
- * namespace: a global reference is returned even if it
- * wasn't explicitly requested.
- */
-
- *indexPtr = -1;
- } else {
- *indexPtr = -2;
- }
- } else { /* Var wasn't found and not to create it. */
+ if (!create) { /* Var wasn't found and not to create it. */
*errMsgPtr = NOSUCHVAR;
return NULL;
}
+
+ /*
+ * Var wasn't found so create it.
+ */
+
+ TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags,
+ &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
+ if (varNsPtr == NULL) {
+ *errMsgPtr = BADNAMESPACE;
+ return NULL;
+ } else if (tail == NULL) {
+ *errMsgPtr = MISSINGNAME;
+ return NULL;
+ }
+ if (tail != varName) {
+ tailPtr = Tcl_NewStringObj(tail, -1);
+ } else {
+ tailPtr = varNamePtr;
+ }
+ varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew);
+ if (lookGlobal) {
+ /*
+ * The variable was created starting from the global
+ * namespace: a global reference is returned even if it wasn't
+ * explicitly requested.
+ */
+
+ *indexPtr = -1;
+ } else {
+ *indexPtr = -2;
+ }
}
} else { /* Local var: look in frame varFramePtr. */
int localCt = varFramePtr->numCompiledLocals;
@@ -1072,8 +1074,6 @@ TclLookupArrayElement(
{
int isNew;
Var *varPtr;
- TclVarHashTable *tablePtr;
- Namespace *nsPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
@@ -1106,16 +1106,7 @@ TclLookupArrayElement(
return NULL;
}
- TclSetVarArray(arrayPtr);
- tablePtr = ckalloc(sizeof(TclVarHashTable));
- arrayPtr->value.tablePtr = tablePtr;
-
- if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
- nsPtr = TclGetVarNsPtr(arrayPtr);
- } else {
- nsPtr = NULL;
- }
- TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr);
+ TclInitArrayVar(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY,
@@ -1171,6 +1162,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetVar
const char *
Tcl_GetVar(
@@ -1191,6 +1183,7 @@ Tcl_GetVar(
}
return TclGetString(resultPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1463,6 +1456,28 @@ TclPtrGetVarIdx(
return varPtr->value.objPtr;
}
+ /*
+ * Return the array default value if any.
+ */
+
+ if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) {
+ return TclGetArrayDefault(arrayPtr);
+ }
+ if (TclIsVarArrayElement(varPtr) && !arrayPtr) {
+ /*
+ * UGLY! Peek inside the implementation of things. This lets us get
+ * the default of an array even when we've been [upvar]ed to just an
+ * element of the array.
+ */
+
+ ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *)
+ ((VarInHash *) varPtr)->entry.tablePtr;
+
+ if (avhtPtr->defaultObj) {
+ return avhtPtr->defaultObj;
+ }
+ }
+
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
@@ -1507,7 +1522,7 @@ TclPtrGetVarIdx(
int
Tcl_SetObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1559,6 +1574,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetVar
const char *
Tcl_SetVar(
@@ -1571,18 +1587,15 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
-
- Tcl_IncrRefCount(varNamePtr);
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL,
Tcl_NewStringObj(newValue, -1), flags);
- Tcl_DecrRefCount(varNamePtr);
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1824,6 +1837,130 @@ TclPtrSetVar(
/*
*----------------------------------------------------------------------
*
+ * ListAppendInVar, StringAppendInVar --
+ *
+ * Support functions for TclPtrSetVarIdx that implement various types of
+ * appending operations.
+ *
+ * Results:
+ * ListAppendInVar returns a Tcl result code (from the core list append
+ * operation). StringAppendInVar has no return value.
+ *
+ * Side effects:
+ * The variable or element of the array is updated. This may make the
+ * variable/element exist. Reference counts of values may be updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+ListAppendInVar(
+ Tcl_Interp *interp,
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ if (oldValuePtr == NULL) {
+ /*
+ * No previous value. Check for defaults if there's an array we can
+ * ask this of.
+ */
+
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ oldValuePtr = Tcl_DuplicateObj(defValuePtr);
+ }
+ }
+
+ if (oldValuePtr == NULL) {
+ /*
+ * No default. [lappend] semantics say this is like being an empty
+ * string.
+ */
+
+ TclNewObj(oldValuePtr);
+ }
+ varPtr->value.objPtr = oldValuePtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ } else if (Tcl_IsShared(oldValuePtr)) {
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ }
+
+ return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr);
+}
+
+static inline void
+StringAppendInVar(
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ /*
+ * If there was no previous value, either we use the array's default (if
+ * this is an array with a default at all) or we treat this as a simple
+ * set.
+ */
+
+ if (oldValuePtr == NULL) {
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ /*
+ * This is *almost* the same as the shared path below, except
+ * that the original value reference in defValuePtr is not
+ * decremented.
+ */
+
+ Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr);
+
+ varPtr->value.objPtr = valuePtr;
+ TclContinuationsCopy(valuePtr, defValuePtr);
+ Tcl_IncrRefCount(valuePtr);
+ Tcl_AppendObjToObj(valuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+ return;
+ }
+ }
+ varPtr->value.objPtr = newValuePtr;
+ Tcl_IncrRefCount(newValuePtr);
+ return;
+ }
+
+ /*
+ * We append newValuePtr's bytes but don't change its ref count. Unless
+ * the reference is shared, when we have to duplicate in order to be safe
+ * to modify at all.
+ */
+
+ if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+
+ TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
+
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
+ }
+
+ Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclPtrSetVarIdx --
*
* This function is the same as Tcl_SetVar2Ex above, except that it
@@ -1936,44 +2073,13 @@ TclPtrSetVarIdx(
}
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (flags & TCL_LIST_ELEMENT) { /* Append list element. */
- if (oldValuePtr == NULL) {
- TclNewObj(oldValuePtr);
- varPtr->value.objPtr = oldValuePtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- } else if (Tcl_IsShared(oldValuePtr)) {
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- }
- result = Tcl_ListObjAppendElement(interp, oldValuePtr,
+ result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr,
newValuePtr);
if (result != TCL_OK) {
goto earlyError;
}
} else { /* Append string. */
- /*
- * We append newValuePtr's bytes but don't change its ref count.
- */
-
- if (oldValuePtr == NULL) {
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr);
- } else {
- if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
-
- TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
-
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
- }
- Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
- if (newValuePtr->refCount == 0) {
- Tcl_DecrRefCount(newValuePtr);
- }
- }
+ StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr);
}
} else if (newValuePtr != oldValuePtr) {
/*
@@ -2263,6 +2369,7 @@ TclPtrIncrObjVarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
@@ -2291,6 +2398,7 @@ Tcl_UnsetVar(
Tcl_DecrRefCount(varNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2708,7 +2816,7 @@ UnsetVarStruct(
int
Tcl_UnsetObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2775,7 +2883,7 @@ Tcl_UnsetObjCmd(
int
Tcl_AppendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2840,7 +2948,7 @@ Tcl_AppendObjCmd(
int
Tcl_LappendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2869,7 +2977,7 @@ Tcl_LappendObjCmd(
return TCL_ERROR;
}
} else {
- result = TclListObjLength(interp, newValuePtr, &numElems);
+ result = TclListObjLengthM(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
@@ -2927,7 +3035,7 @@ Tcl_LappendObjCmd(
createdNewObj = 1;
}
- result = TclListObjLength(interp, varValuePtr, &numElems);
+ result = TclListObjLengthM(interp, varValuePtr, &numElems);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
(objc-2), (objv+2));
@@ -2964,6 +3072,310 @@ Tcl_LappendObjCmd(
/*
*----------------------------------------------------------------------
*
+ * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext --
+ *
+ * These functions implement the "array for" Tcl command.
+ * array for {k v} a {}
+ * The array for command iterates over the array, setting the the
+ * specified loop variables, and executing the body each iteration.
+ *
+ * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
+ *
+ * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
+ * inside the structure and calls VarHashFirstEntry to start the hash
+ * iteration.
+ *
+ * ArrayForNRCmd() does not execute the body or set the loop variables,
+ * it only initializes the iterator.
+ *
+ * ArrayForLoopCallback() iterates over the entire array, executing the
+ * body each time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ArrayObjNext(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, /* array */
+ Var *varPtr, /* array */
+ ArraySearch *searchPtr,
+ Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key
+ * written into, or NULL. */
+ Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the
+ * value written into, or NULL.*/
+{
+ Tcl_Obj *keyObj;
+ Tcl_Obj *valueObj = NULL;
+ int gotValue;
+ int donerc;
+
+ donerc = TCL_BREAK;
+
+ if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
+ donerc = TCL_ERROR;
+ return donerc;
+ }
+
+ gotValue = 0;
+ while (1) {
+ Tcl_HashEntry *hPtr = searchPtr->nextEntry;
+
+ if (hPtr != NULL) {
+ searchPtr->nextEntry = NULL;
+ } else {
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ gotValue = 0;
+ break;
+ }
+ }
+ varPtr = VarHashGetValue(hPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ gotValue = 1;
+ break;
+ }
+ }
+
+ if (!gotValue) {
+ return donerc;
+ }
+
+ donerc = TCL_CONTINUE;
+
+ keyObj = VarHashGetKey(varPtr);
+ *keyPtrPtr = keyObj;
+ valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj,
+ TCL_LEAVE_ERR_MSG);
+ *valuePtrPtr = valueObj;
+
+ return donerc;
+}
+
+static int
+ArrayForObjCmd(
+ void *clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, ArrayForNRCmd, clientData, objc, objv);
+}
+
+static int
+ArrayForNRCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
+ ArraySearch *searchPtr = NULL;
+ Var *varPtr;
+ int isArray, numVars;
+
+ /*
+ * array for {k v} a body
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse arguments.
+ */
+
+ if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (numVars != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+
+ /*
+ * Make a new array search, put it on the stack.
+ */
+
+ searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
+ ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
+
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish.
+ */
+
+ varListObj = TclListObjCopy(NULL, objv[1]);
+ scriptObj = objv[3];
+ Tcl_IncrRefCount(scriptObj);
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+ arrayNameObj, scriptObj);
+ return TCL_OK;
+}
+
+static int
+ArrayForLoopCallback(
+ void *data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ ArraySearch *searchPtr = (ArraySearch *)data[0];
+ Tcl_Obj *varListObj = (Tcl_Obj *)data[1];
+ Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
+ Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
+ Tcl_Obj **varv;
+ Tcl_Obj *keyObj, *valueObj;
+ Var *varPtr;
+ Var *arrayPtr;
+ int done, varc;
+
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ done = TCL_ERROR;
+
+ 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_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"array for\" body line %d)",
+ Tcl_GetErrorLine(interp)));
+ }
+ goto arrayfordone;
+ }
+
+ /*
+ * Get the next mapping from the array.
+ */
+
+ keyObj = NULL;
+ valueObj = NULL;
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ if (varPtr == NULL) {
+ done = TCL_ERROR;
+ } else {
+ done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj,
+ &valueObj);
+ }
+
+ result = TCL_OK;
+ if (done != TCL_CONTINUE) {
+ Tcl_ResetResult(interp);
+ if (done == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array changed during iteration", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
+ varPtr->flags |= TCL_LEAVE_ERR_MSG;
+ result = done;
+ }
+ goto arrayfordone;
+ }
+
+ TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
+ if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
+ if (valueObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
+ }
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+ arrayNameObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ arrayfordone:
+ if (done != TCL_ERROR) {
+ /*
+ * If the search was terminated by an array change, the
+ * VAR_SEARCH_ACTIVE flag will no longer be set.
+ */
+
+ ArrayDoneSearch(iPtr, varPtr, searchPtr);
+ Tcl_DecrRefCount(searchPtr->name);
+ ckfree(searchPtr);
+ }
+
+ TclDecrRefCount(varListObj);
+ TclDecrRefCount(scriptObj);
+ return result;
+}
+
+/*
+ * ArrayPopulateSearch
+ */
+
+static void
+ArrayPopulateSearch(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+ if (isNew) {
+ searchPtr->id = 1;
+ varPtr->flags |= VAR_SEARCH_ACTIVE;
+ searchPtr->nextPtr = NULL;
+ } else {
+ searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+ searchPtr->nextPtr = (ArraySearch *)Tcl_GetHashValue(hPtr);
+ }
+ searchPtr->varPtr = varPtr;
+ searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+ &searchPtr->search);
+ Tcl_SetHashValue(hPtr, searchPtr);
+ searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
+ TclGetString(arrayNameObj));
+ Tcl_IncrRefCount(searchPtr->name);
+}
+/*
+ *----------------------------------------------------------------------
+ *
* ArrayStartSearchCmd --
*
* This object-based function is invoked to process the "array
@@ -2981,17 +3393,14 @@ Tcl_LappendObjCmd(
static int
ArrayStartSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
- int isNew, isArray;
+ int isArray;
ArraySearch *searchPtr;
- const char *varName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
@@ -3010,24 +3419,54 @@ ArrayStartSearchCmd(
* Make a new array search with a free name.
*/
- varName = TclGetString(objv[1]);
- searchPtr = ckalloc(sizeof(ArraySearch));
- hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
- if (isNew) {
- searchPtr->id = 1;
- varPtr->flags |= VAR_SEARCH_ACTIVE;
- searchPtr->nextPtr = NULL;
+ searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
+ ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr);
+ Tcl_SetObjResult(interp, searchPtr->name);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayDoneSearch --
+ *
+ * Removes the search from the hash of active searches.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+ArrayDoneSearch(
+ Interp *iPtr,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr;
+ ArraySearch *prevPtr;
+
+ /*
+ * Unhook the search from the list of searches associated with the
+ * variable.
+ */
+
+ hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+ if (hPtr == NULL) {
+ return;
+ }
+ if (searchPtr == Tcl_GetHashValue(hPtr)) {
+ if (searchPtr->nextPtr) {
+ Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+ } else {
+ varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(hPtr);
+ }
} else {
- searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
- searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+ for (prevPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); ; prevPtr=prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ break;
+ }
+ }
}
- searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
- &searchPtr->search);
- Tcl_SetHashValue(hPtr, searchPtr);
- Tcl_SetObjResult(interp,
- Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
- return TCL_OK;
}
/*
@@ -3049,12 +3488,12 @@ ArrayStartSearchCmd(
static int
ArrayAnyMoreCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
int gotValue, isArray;
@@ -3127,7 +3566,7 @@ ArrayAnyMoreCmd(
static int
ArrayNextElementCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3207,16 +3646,15 @@ ArrayNextElementCmd(
static int
ArrayDoneSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
- ArraySearch *searchPtr, *prevPtr;
+ ArraySearch *searchPtr;
int isArray;
if (objc != 3) {
@@ -3243,27 +3681,8 @@ ArrayDoneSearchCmd(
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);
- }
- } else {
- for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
- }
- }
- }
+ ArrayDoneSearch(iPtr, varPtr, searchPtr);
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
}
@@ -3287,7 +3706,7 @@ ArrayDoneSearchCmd(
static int
ArrayExistsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3327,7 +3746,7 @@ ArrayExistsCmd(
static int
ArrayGetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3419,7 +3838,7 @@ ArrayGetCmd(
*/
TclNewObj(tmpResObj);
- result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr);
+ result = TclListObjGetElementsM(interp, nameLstObj, &count, &nameObjPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
@@ -3486,7 +3905,7 @@ ArrayGetCmd(
static int
ArrayNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3653,7 +4072,7 @@ TclFindArrayPtrElements(
static int
ArraySetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3692,7 +4111,7 @@ ArraySetCmd(
*/
arrayElemObj = objv[2];
- if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
+ if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
@@ -3742,8 +4161,7 @@ ArraySetCmd(
int elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
- result = TclListObjGetElements(interp, arrayElemObj,
- &elemLen, &elemPtrs);
+ result = TclListObjLengthM(interp, arrayElemObj, &elemLen);
if (result != TCL_OK) {
return result;
}
@@ -3756,6 +4174,11 @@ ArraySetCmd(
if (elemLen == 0) {
goto ensureArray;
}
+ result = TclListObjGetElementsM(interp, arrayElemObj,
+ &elemLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
/*
* We needn't worry about traces invalidating arrayPtr: should that be
@@ -3805,9 +4228,7 @@ ArraySetCmd(
return TCL_ERROR;
}
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
return TCL_OK;
}
@@ -3830,7 +4251,7 @@ ArraySetCmd(
static int
ArraySizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3865,7 +4286,7 @@ ArraySizeCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
return TCL_OK;
}
@@ -3889,7 +4310,7 @@ ArraySizeCmd(
static int
ArrayStatsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3943,7 +4364,7 @@ ArrayStatsCmd(
static int
ArrayUnsetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -4083,8 +4504,10 @@ TclInitArrayCmd(
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
+ {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
{"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -4394,6 +4817,7 @@ TclPtrObjMakeUpvarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
@@ -4427,6 +4851,7 @@ Tcl_UpVar(
Tcl_DecrRefCount(localNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -4564,7 +4989,7 @@ Tcl_GetVariableFullName(
int
Tcl_GlobalObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4668,7 +5093,7 @@ Tcl_GlobalObjCmd(
int
Tcl_VariableObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4801,7 +5226,7 @@ Tcl_VariableObjCmd(
int
Tcl_UpvarObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4881,75 +5306,6 @@ Tcl_UpvarObjCmd(
/*
*----------------------------------------------------------------------
*
- * SetArraySearchObj --
- *
- * This function converts the given tcl object into one that has the
- * "array search" internal type.
- *
- * Results:
- * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when
- * an error message will be placed in the interpreter's result.)
- *
- * Side effects:
- * Updates the internal type and representation of the object to make
- * this an array-search object. See the tclArraySearchType declaration
- * above for details of the internal representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetArraySearchObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- const char *string;
- char *end; /* Can't be const due to strtoul defn. */
- int id;
- size_t offset;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = TclGetString(objPtr);
-
- /*
- * Parse the id into the three parts separated by dashes.
- */
-
- if ((string[0] != 's') || (string[1] != '-')) {
- goto syntax;
- }
- id = strtoul(string+2, &end, 10);
- if ((end == (string+2)) || (*end != '-')) {
- goto syntax;
- }
-
- /*
- * Can't perform value check in this context, so place reference to place
- * in string to use for the check in the object instead.
- */
-
- end++;
- offset = end - string;
-
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclArraySearchType;
- objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id);
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset);
- return TCL_OK;
-
- syntax:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "illegal search identifier \"%s\"", string));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* ParseSearchId --
*
* This function translates from a tcl object to a pointer to an active
@@ -4960,10 +5316,6 @@ SetArraySearchObj(
* or NULL if there isn't one. If NULL is returned, the interp's result
* contains an error message.
*
- * Side effects:
- * The tcl object might have its internal type and representation
- * modified.
- *
*----------------------------------------------------------------------
*/
@@ -4979,65 +5331,43 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
- const char *string;
- size_t offset;
- int id;
ArraySearch *searchPtr;
- const char *varName = TclGetString(varNamePtr);
-
- /*
- * Parse the id.
- */
-
- if ((handleObj->typePtr != &tclArraySearchType)
- && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
- return NULL;
- }
-
- /*
- * Extract the information out of the Tcl_Obj.
- */
-
- id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1);
- string = TclGetString(handleObj);
- offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2);
-
- /*
- * This test cannot be placed inside the Tcl_Obj machinery, since it is
- * dependent on the variable context.
- */
-
- if (strcmp(string+offset, varName) != 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "search identifier \"%s\" isn't for variable \"%s\"",
- string, varName));
- goto badLookup;
- }
-
- /*
- * Search through the list of active searches on the interpreter to see if
- * the desired one exists.
- *
- * Note that we cannot store the searchPtr directly in the Tcl_Obj as that
- * would run into trouble when DeleteSearches() was called so we must scan
- * this list every time.
- */
+ const char *handle = TclGetString(handleObj);
+ char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
- for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ /* First look for same (Tcl_Obj *) */
+ for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ searchPtr = searchPtr->nextPtr) {
+ if (searchPtr->name == handleObj) {
+ return searchPtr;
+ }
+ }
+ /* Fallback: do string compares. */
+ for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
- if (searchPtr->id == id) {
+ if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
return searchPtr;
}
}
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't find search \"%s\"", string));
- badLookup:
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
+ if ((handle[0] != 's') || (handle[1] != '-')
+ || (strtoul(handle + 2, &end, 10), end == (handle + 2))
+ || (*end != '-')) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal search identifier \"%s\"", handle));
+ } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "search identifier \"%s\" isn't for variable \"%s\"",
+ handle, TclGetString(varNamePtr)));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", handle));
+ }
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL);
return NULL;
}
@@ -5072,6 +5402,7 @@ DeleteSearches(
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
@@ -5364,8 +5695,7 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
- VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree(varPtr->value.tablePtr);
+ DeleteArrayVar(varPtr);
}
/*
@@ -5443,28 +5773,6 @@ TclObjVarErrMsg(
*/
/*
- * Panic functions that should never be called in normal operation.
- */
-
-static void
-PanicOnUpdateVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "updateStringProc",
- objPtr->typePtr->name);
-}
-
-static int
-PanicOnSetVarName(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "setFromAnyProc",
- objPtr->typePtr->name);
- return TCL_ERROR;
-}
-
-/*
* localVarName -
*
* INTERNALREP DEFINITION:
@@ -5477,12 +5785,15 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+
+ LocalGetInternalRep(objPtr, index, namePtr);
+ index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5490,17 +5801,14 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+ LocalGetInternalRep(srcPtr, index, namePtr);
if (!namePtr) {
namePtr = srcPtr;
}
- dupPtr->internalRep.twoPtrValue.ptr1 = namePtr;
- Tcl_IncrRefCount(namePtr);
-
- dupPtr->internalRep.twoPtrValue.ptr2 =
- srcPtr->internalRep.twoPtrValue.ptr2;
- dupPtr->typePtr = &localVarNameType;
+ LocalSetInternalRep(dupPtr, index, namePtr);
}
/*
@@ -5516,14 +5824,16 @@ static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *elem = objPtr->internalRep.twoPtrValue.ptr2;
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
+
+ ParsedGetInternalRep(objPtr, parsed, arrayPtr, elem);
+ parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
- ckfree(elem);
+ TclDecrRefCount(elem);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5531,58 +5841,13 @@ DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
- char *elemCopy;
- unsigned elemLen;
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
- if (arrayPtr != NULL) {
- Tcl_IncrRefCount(arrayPtr);
- elemLen = strlen(elem);
- elemCopy = (char *)ckalloc(elemLen + 1);
- memcpy(elemCopy, elem, elemLen);
- *(elemCopy + elemLen) = '\0';
- elem = elemCopy;
- }
+ ParsedGetInternalRep(srcPtr, parsed, arrayPtr, elem);
- dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
- dupPtr->internalRep.twoPtrValue.ptr2 = elem;
- dupPtr->typePtr = &tclParsedVarNameType;
-}
-
-static void
-UpdateParsedVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
- const char *part1;
- char *p;
- int len1, len2, totalLen;
-
- if (arrayPtr == NULL) {
- /*
- * This is a parsed scalar name: what is it doing here?
- */
-
- Tcl_Panic("scalar parsedVarName without a string rep");
- }
-
- part1 = TclGetStringFromObj(arrayPtr, &len1);
- len2 = strlen(part2);
-
- totalLen = len1 + len2 + 2;
- p = ckalloc(totalLen + 1);
- objPtr->bytes = p;
- objPtr->length = totalLen;
-
- memcpy(p, part1, len1);
- p += len1;
- *p++ = '(';
- memcpy(p, part2, len2);
- p += len2;
- *p++ = ')';
- *p = '\0';
+ parsed++; /* Silence compiler. */
+ ParsedSetInternalRep(dupPtr, arrayPtr, elem);
}
/*
@@ -5773,7 +6038,7 @@ ObjFindNamespaceVar(
int
TclInfoVarsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -5964,7 +6229,7 @@ TclInfoVarsCmd(
int
TclInfoGlobalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6057,7 +6322,7 @@ TclInfoGlobalsCmd(
int
TclInfoLocalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6207,25 +6472,50 @@ AppendLocals(
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
- CallContext *contextPtr = iPtr->varFramePtr->clientData;
- Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Method *mPtr = (Method *)
+ Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData);
+ PrivateVariableMapping *privatePtr;
if (mPtr->declaringObjectPtr) {
- FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
+ Object *oPtr = mPtr->declaringObjectPtr;
+
+ FOREACH(objNamePtr, oPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
if (added && (!pattern ||
Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
}
}
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+ &added);
+ if (added && (!pattern ||
+ Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+ pattern))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ privatePtr->variableObj);
+ }
+ }
} else {
- FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
+ Class *clsPtr = mPtr->declaringClassPtr;
+
+ FOREACH(objNamePtr, clsPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
if (added && (!pattern ||
Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
}
}
+ FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+ Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+ &added);
+ if (added && (!pattern ||
+ Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+ pattern))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ privatePtr->variableObj);
+ }
+ }
}
}
Tcl_DeleteHashTable(&addedTable);
@@ -6247,7 +6537,7 @@ TclInitVarHashTable(
static Tcl_HashEntry *
AllocVarEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
@@ -6319,6 +6609,263 @@ CompareVarKeys(
return ((l1 == l2) && !memcmp(p1, p2, l1));
}
+/*----------------------------------------------------------------------
+ *
+ * ArrayDefaultCmd --
+ *
+ * This function implements the 'array default' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ArrayDefaultCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *const options[] = {
+ "get", "set", "exists", "unset", NULL
+ };
+ enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET };
+ Tcl_Obj *arrayNameObj, *defaultValueObj;
+ Var *varPtr, *arrayPtr;
+ int isArray, option;
+
+ /*
+ * Parse arguments.
+ */
+
+ if (objc != 3 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option",
+ 0, &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum arrayDefaultOptionsEnum)option) {
+ case OPT_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ if (!defaultValueObj) {
+ /* Array default must exist. */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array has no default value", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_SET:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Attempt to create array if needed.
+ */
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (arrayPtr) {
+ /*
+ * Not a valid array name.
+ */
+
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ NEEDARRAY, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(arrayNameObj), NULL);
+ return TCL_ERROR;
+ }
+ if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ /*
+ * Not an array.
+ */
+
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ NEEDARRAY, -1);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ return TCL_ERROR;
+ }
+
+ if (!TclIsVarArray(varPtr)) {
+ TclInitArrayVar(varPtr);
+ }
+ defaultValueObj = objv[3];
+ SetArrayDefault(varPtr, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_EXISTS:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Undefined variables (whether or not they have storage allocated) do
+ * not have defaults, and this is not an error case.
+ */
+
+ if (!varPtr || TclIsVarUndefined(varPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ } else {
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj));
+ }
+ return TCL_OK;
+
+ case OPT_UNSET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ if (varPtr && !TclIsVarUndefined(varPtr)) {
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+ SetArrayDefault(varPtr, NULL);
+ }
+ return TCL_OK;
+ }
+
+ /* Unreached */
+ return TCL_ERROR;
+}
+
+/*
+ * Initialize array variable.
+ */
+
+void
+TclInitArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable));
+
+ /*
+ * Mark the variable as an array.
+ */
+
+ TclSetVarArray(arrayPtr);
+
+ /*
+ * Regular TclVarHashTable initialization.
+ */
+
+ arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr;
+ TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr));
+
+ /*
+ * Default value initialization.
+ */
+
+ tablePtr->defaultObj = NULL;
+}
+
+/*
+ * Cleanup array variable.
+ */
+
+static void
+DeleteArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Default value cleanup.
+ */
+
+ SetArrayDefault(arrayPtr, NULL);
+
+ /*
+ * Regular TclVarHashTable cleanup.
+ */
+
+ VarHashDeleteTable(arrayPtr->value.tablePtr);
+ ckfree(tablePtr);
+}
+
+/*
+ * Get array default value if any.
+ */
+
+Tcl_Obj *
+TclGetArrayDefault(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ return tablePtr->defaultObj;
+}
+
+/*
+ * Set/replace/unset array default value.
+ */
+
+static void
+SetArrayDefault(
+ Var *arrayPtr,
+ Tcl_Obj *defaultObj)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Increment/decrement refcount twice to ensure that the object is shared,
+ * so that it doesn't get modified accidentally by the folling code:
+ *
+ * array default set v 1
+ * lappend v(a) 2; # returns a new object {1 2}
+ * set v(b); # returns the original default object "1"
+ */
+
+ if (tablePtr->defaultObj) {
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ }
+ tablePtr->defaultObj = defaultObj;
+ if (tablePtr->defaultObj) {
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ }
+}
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
new file mode 100644
index 0000000..1b602ea
--- /dev/null
+++ b/generic/tclZipfs.c
@@ -0,0 +1,6015 @@
+/*
+ * tclZipfs.c --
+ *
+ * Implementation of the ZIP filesystem used in TIP 430
+ * Adapted from the implementation for AndroWish.
+ *
+ * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com>
+ * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de>
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * This file is distributed in two ways:
+ * generic/tclZipfs.c file in the TIP430-enabled Tcl cores.
+ * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430
+ * projects.
+ */
+
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+#ifndef _WIN32
+#include <sys/mman.h>
+#endif /* _WIN32*/
+
+#ifndef MAP_FILE
+#define MAP_FILE 0
+#endif /* !MAP_FILE */
+#define NOBYFOUR
+#ifndef TBLS
+#define TBLS 1
+#endif
+
+#if !defined(_WIN32) && !defined(NO_DLFCN_H)
+#include <dlfcn.h>
+#endif
+
+/*
+ * Macros to report errors only if an interp is present.
+ */
+
+#define ZIPFS_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \
+ } \
+ } while (0)
+#define ZIPFS_MEM_ERROR(interp) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj( \
+ "out of memory", -1)); \
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \
+ } \
+ } while (0)
+#define ZIPFS_POSIX_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
+ "%s: %s", errstr, Tcl_PosixError(interp))); \
+ } \
+ } while (0)
+#define ZIPFS_ERROR_CODE(interp,errcode) \
+ do { \
+ if (interp) { \
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \
+ } \
+ } while (0)
+
+
+#ifdef HAVE_ZLIB
+#include "zlib.h"
+#include "crypt.h"
+#include "zutil.h"
+#include "crc32.h"
+
+static const z_crc_t* crc32tab;
+
+/*
+** We are compiling as part of the core.
+** TIP430 style zipfs prefix
+*/
+
+#define ZIPFS_VOLUME "//zipfs:/"
+#define ZIPFS_VOLUME_LEN 9
+#define ZIPFS_APP_MOUNT "//zipfs:/app"
+#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl"
+#define ZIPFS_FALLBACK_ENCODING "cp437"
+
+/*
+ * Various constants and offsets found in ZIP archive files
+ */
+
+#define ZIP_SIG_LEN 4
+
+/*
+ * Local header of ZIP archive member (at very beginning of each member).
+ */
+
+#define ZIP_LOCAL_HEADER_SIG 0x04034b50
+#define ZIP_LOCAL_HEADER_LEN 30
+#define ZIP_LOCAL_SIG_OFFS 0
+#define ZIP_LOCAL_VERSION_OFFS 4
+#define ZIP_LOCAL_FLAGS_OFFS 6
+#define ZIP_LOCAL_COMPMETH_OFFS 8
+#define ZIP_LOCAL_MTIME_OFFS 10
+#define ZIP_LOCAL_MDATE_OFFS 12
+#define ZIP_LOCAL_CRC32_OFFS 14
+#define ZIP_LOCAL_COMPLEN_OFFS 18
+#define ZIP_LOCAL_UNCOMPLEN_OFFS 22
+#define ZIP_LOCAL_PATHLEN_OFFS 26
+#define ZIP_LOCAL_EXTRALEN_OFFS 28
+
+/*
+ * Central header of ZIP archive member at end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_HEADER_SIG 0x02014b50
+#define ZIP_CENTRAL_HEADER_LEN 46
+#define ZIP_CENTRAL_SIG_OFFS 0
+#define ZIP_CENTRAL_VERSIONMADE_OFFS 4
+#define ZIP_CENTRAL_VERSION_OFFS 6
+#define ZIP_CENTRAL_FLAGS_OFFS 8
+#define ZIP_CENTRAL_COMPMETH_OFFS 10
+#define ZIP_CENTRAL_MTIME_OFFS 12
+#define ZIP_CENTRAL_MDATE_OFFS 14
+#define ZIP_CENTRAL_CRC32_OFFS 16
+#define ZIP_CENTRAL_COMPLEN_OFFS 20
+#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24
+#define ZIP_CENTRAL_PATHLEN_OFFS 28
+#define ZIP_CENTRAL_EXTRALEN_OFFS 30
+#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32
+#define ZIP_CENTRAL_DISKFILE_OFFS 34
+#define ZIP_CENTRAL_IATTR_OFFS 36
+#define ZIP_CENTRAL_EATTR_OFFS 38
+#define ZIP_CENTRAL_LOCALHDR_OFFS 42
+
+/*
+ * Central end signature at very end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_END_SIG 0x06054b50
+#define ZIP_CENTRAL_END_LEN 22
+#define ZIP_CENTRAL_END_SIG_OFFS 0
+#define ZIP_CENTRAL_DISKNO_OFFS 4
+#define ZIP_CENTRAL_DISKDIR_OFFS 6
+#define ZIP_CENTRAL_ENTS_OFFS 8
+#define ZIP_CENTRAL_TOTALENTS_OFFS 10
+#define ZIP_CENTRAL_DIRSIZE_OFFS 12
+#define ZIP_CENTRAL_DIRSTART_OFFS 16
+#define ZIP_CENTRAL_COMMENTLEN_OFFS 20
+
+#define ZIP_MIN_VERSION 20
+#define ZIP_COMPMETH_STORED 0
+#define ZIP_COMPMETH_DEFLATED 8
+
+#define ZIP_PASSWORD_END_SIG 0x5a5a4b50
+
+#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024)
+
+/*
+ * Windows drive letters.
+ */
+
+#ifdef _WIN32
+static const char drvletters[] =
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+#endif /* _WIN32 */
+
+/*
+ * Mutex to protect localtime(3) when no reentrant version available.
+ */
+
+#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS
+TCL_DECLARE_MUTEX(localtimeMutex)
+#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */
+
+/*
+ * Forward declaration.
+ */
+
+struct ZipEntry;
+
+/*
+ * In-core description of mounted ZIP archive file.
+ */
+
+typedef struct ZipFile {
+ char *name; /* Archive name */
+ size_t nameLength; /* Length of archive name */
+ char isMemBuffer; /* When true, not a file but a memory buffer */
+ Tcl_Channel chan; /* Channel handle or NULL */
+ unsigned char *data; /* Memory mapped or malloc'ed file */
+ size_t length; /* Length of memory mapped file */
+ void *ptrToFree; /* Non-NULL if malloc'ed file */
+ size_t numFiles; /* Number of files in archive */
+ size_t baseOffset; /* Archive start */
+ size_t passOffset; /* Password start */
+ size_t directoryOffset; /* Archive directory start */
+ unsigned char passBuf[264]; /* Password buffer */
+ size_t numOpen; /* Number of open files on archive */
+ struct ZipEntry *entries; /* List of files in archive */
+ struct ZipEntry *topEnts; /* List of top-level dirs in archive */
+ char *mountPoint; /* Mount point name */
+ size_t mountPointLen; /* Length of mount point name */
+#ifdef _WIN32
+ HANDLE mountHandle; /* Handle used for direct file access. */
+#endif /* _WIN32 */
+} ZipFile;
+
+/*
+ * In-core description of file contained in mounted ZIP archive.
+ * ZIP_ATTR_
+ */
+
+typedef struct ZipEntry {
+ char *name; /* The full pathname of the virtual file */
+ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
+ size_t offset; /* Data offset into memory mapped ZIP file */
+ int numBytes; /* Uncompressed size of the virtual file */
+ int numCompressedBytes; /* Compressed size of the virtual file */
+ int compressMethod; /* Compress method */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int depth; /* Number of slashes in path. */
+ int crc32; /* CRC-32 */
+ int timestamp; /* Modification time */
+ int isEncrypted; /* True if data is encrypted */
+ unsigned char *data; /* File data if written */
+ struct ZipEntry *next; /* Next file in the same archive */
+ struct ZipEntry *tnext; /* Next top-level dir in archive */
+} ZipEntry;
+
+/*
+ * File channel for file contained in mounted ZIP archive.
+ */
+
+typedef struct ZipChannel {
+ ZipFile *zipFilePtr; /* The ZIP file holding this channel */
+ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
+ size_t maxWrite; /* Maximum size for write */
+ size_t numBytes; /* Number of bytes of uncompressed data */
+ size_t numRead; /* Position of next byte to be read from the
+ * channel */
+ unsigned char *ubuf; /* Pointer to the uncompressed data */
+ int iscompr; /* True if data is compressed */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int isEncrypted; /* True if data is encrypted */
+ int isWriting; /* True if open for writing */
+ unsigned long keys[3]; /* Key for decryption */
+} ZipChannel;
+
+/*
+ * Global variables.
+ *
+ * Most are kept in single ZipFS struct. When build with threading support
+ * this struct is protected by the ZipFSMutex (see below).
+ *
+ * The "fileHash" component is the process-wide global table of all known ZIP
+ * archive members in all mounted ZIP archives.
+ *
+ * The "zipHash" components is the process wide global table of all mounted
+ * ZIP archive files.
+ */
+
+static struct {
+ int initialized; /* True when initialized */
+ int lock; /* RW lock, see below */
+ int waiters; /* RW lock, see below */
+ int wrmax; /* Maximum write size of a file; only written
+ * to from Tcl code in a trusted interpreter,
+ * so NOT protected by mutex. */
+ char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when
+ * they are believed to not be UTF-8; only
+ * written to from Tcl code in a trusted
+ * interpreter, so not protected by mutex. */
+ Tcl_Encoding utf8; /* The UTF-8 encoding that we prefer to use
+ * for the strings (especially filenames)
+ * embedded in a ZIP. Other encodings are used
+ * dynamically. */
+ int idCount; /* Counter for channel names */
+ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
+ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
+} ZipFS = {
+ 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, NULL, 0,
+ {0,{0,0,0,0},0,0,0,0,0,0,0,0,0},
+ {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}
+};
+
+/*
+ * For password rotation.
+ */
+
+static const char pwrot[17] =
+ "\x00\x80\x40\xC0\x20\xA0\x60\xE0"
+ "\x10\x90\x50\xD0\x30\xB0\x70\xF0";
+
+static const char *zipfs_literal_tcl_library = NULL;
+
+/* Function prototypes */
+
+static int CopyImageFile(Tcl_Interp *interp, const char *imgName,
+ Tcl_Channel out);
+static inline int DescribeMounted(Tcl_Interp *interp,
+ const char *mountPoint);
+static int InitReadableChannel(Tcl_Interp *interp,
+ ZipChannel *info, ZipEntry *z);
+static int InitWritableChannel(Tcl_Interp *interp,
+ ZipChannel *info, ZipEntry *z, int trunc);
+static inline int ListMountPoints(Tcl_Interp *interp);
+static void SerializeCentralDirectoryEntry(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ ZipEntry *z, size_t nameLength);
+static void SerializeCentralDirectorySuffix(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ int entryCount, long long directoryStartOffset,
+ long long suffixStartOffset);
+static void SerializeLocalEntryHeader(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ ZipEntry *z, int nameLength, int align);
+#if !defined(STATIC_BUILD)
+static int ZipfsAppHookFindTclInit(const char *archive);
+#endif
+static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr,
+ void **clientDataPtr);
+static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
+static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
+static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode);
+static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int mode, int permissions);
+static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr,
+ const char *pattern, Tcl_GlobTypeData *types);
+static void ZipFSMatchMountPoints(Tcl_Obj *result,
+ Tcl_Obj *normPathPtr, const char *pattern,
+ Tcl_DString *prefix);
+static Tcl_Obj * ZipFSListVolumesProc(void);
+static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef);
+static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
+static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
+static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf,
+ void *handle);
+static void ZipfsExitHandler(ClientData clientData);
+static void ZipfsMountExitHandler(ClientData clientData);
+static void ZipfsSetup(void);
+static void ZipfsFinalize(void);
+static int ZipChannelClose(void *instanceData,
+ Tcl_Interp *interp, int flags);
+static Tcl_DriverGetHandleProc ZipChannelGetFile;
+static int ZipChannelRead(void *instanceData, char *buf,
+ int toRead, int *errloc);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+static int ZipChannelSeek(void *instanceData, long offset,
+ int mode, int *errloc);
+#endif
+static long long ZipChannelWideSeek(void *instanceData,
+ long long offset, int mode, int *errloc);
+static void ZipChannelWatchChannel(void *instanceData,
+ int mask);
+static int ZipChannelWrite(void *instanceData,
+ const char *buf, int toWrite, int *errloc);
+
+/*
+ * Define the ZIP filesystem dispatch table.
+ */
+
+static const Tcl_Filesystem zipfsFilesystem = {
+ "zipfs",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_2,
+ ZipFSPathInFilesystemProc,
+ NULL, /* dupInternalRepProc */
+ NULL, /* freeInternalRepProc */
+ NULL, /* internalToNormalizedProc */
+ NULL, /* createInternalRepProc */
+ NULL, /* normalizePathProc */
+ ZipFSFilesystemPathTypeProc,
+ ZipFSFilesystemSeparatorProc,
+ ZipFSStatProc,
+ ZipFSAccessProc,
+ ZipFSOpenFileChannelProc,
+ ZipFSMatchInDirectoryProc,
+ NULL, /* utimeProc */
+ NULL, /* linkProc */
+ ZipFSListVolumesProc,
+ ZipFSFileAttrStringsProc,
+ ZipFSFileAttrsGetProc,
+ ZipFSFileAttrsSetProc,
+ NULL, /* createDirectoryProc */
+ NULL, /* removeDirectoryProc */
+ NULL, /* deleteFileProc */
+ NULL, /* copyFileProc */
+ NULL, /* renameFileProc */
+ NULL, /* copyDirectoryProc */
+ NULL, /* lstatProc */
+ (Tcl_FSLoadFileProc *) (void *) ZipFSLoadFile,
+ NULL, /* getCwdProc */
+ NULL, /* chdirProc */
+};
+
+/*
+ * The channel type/driver definition used for ZIP archive members.
+ */
+
+static Tcl_ChannelType ZipChannelType = {
+ "zip", /* Type name. */
+ TCL_CHANNEL_VERSION_5,
+ TCL_CLOSE2PROC, /* Close channel, clean instance data */
+ ZipChannelRead, /* Handle read request */
+ ZipChannelWrite, /* Handle write request */
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ ZipChannelSeek, /* Move location of access point, NULL'able */
+#else
+ NULL, /* Move location of access point, NULL'able */
+#endif
+ NULL, /* Set options, NULL'able */
+ NULL, /* Get options, NULL'able */
+ ZipChannelWatchChannel, /* Initialize notifier */
+ ZipChannelGetFile, /* Get OS handle from the channel */
+ ZipChannelClose, /* 2nd version of close channel, NULL'able */
+ NULL, /* Set blocking mode for raw channel,
+ * NULL'able */
+ NULL, /* Function to flush channel, NULL'able */
+ NULL, /* Function to handle event, NULL'able */
+ ZipChannelWideSeek, /* Wide seek function, NULL'able */
+ NULL, /* Thread action function, NULL'able */
+ NULL, /* Truncate function, NULL'able */
+};
+
+/*
+ * Miscellaneous constants.
+ */
+
+#define ERROR_LENGTH ((size_t) -1)
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort --
+ *
+ * Inline functions to read and write little-endian 16 and 32 bit
+ * integers from/to buffers representing parts of ZIP archives.
+ *
+ * These take bufferStart and bufferEnd pointers, which are used to
+ * maintain a guarantee that out-of-bounds accesses don't happen when
+ * reading or writing critical directory structures.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline unsigned int
+ZipReadInt(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ const unsigned char *ptr)
+{
+ if (ptr < bufferStart || ptr + 4 > bufferEnd) {
+ Tcl_Panic("out of bounds read(4): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ return ptr[0] | (ptr[1] << 8) | (ptr[2] << 16) |
+ ((unsigned int)ptr[3] << 24);
+}
+
+static inline unsigned short
+ZipReadShort(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ const unsigned char *ptr)
+{
+ if (ptr < bufferStart || ptr + 2 > bufferEnd) {
+ Tcl_Panic("out of bounds read(2): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ return ptr[0] | (ptr[1] << 8);
+}
+
+static inline void
+ZipWriteInt(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ unsigned char *ptr,
+ unsigned int value)
+{
+ if (ptr < bufferStart || ptr + 4 > bufferEnd) {
+ Tcl_Panic("out of bounds write(4): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ ptr[0] = value & 0xff;
+ ptr[1] = (value >> 8) & 0xff;
+ ptr[2] = (value >> 16) & 0xff;
+ ptr[3] = (value >> 24) & 0xff;
+}
+
+static inline void
+ZipWriteShort(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ unsigned char *ptr,
+ unsigned short value)
+{
+ if (ptr < bufferStart || ptr + 2 > bufferEnd) {
+ Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ ptr[0] = value & 0xff;
+ ptr[1] = (value >> 8) & 0xff;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ReadLock, WriteLock, Unlock --
+ *
+ * POSIX like rwlock functions to support multiple readers and single
+ * writer on internal structs.
+ *
+ * Limitations:
+ * - a read lock cannot be promoted to a write lock
+ * - a write lock may not be nested
+ *
+ *-------------------------------------------------------------------------
+ */
+
+TCL_DECLARE_MUTEX(ZipFSMutex)
+
+#if TCL_THREADS
+
+static Tcl_Condition ZipFSCond;
+
+static inline void
+ReadLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock < 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock++;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static inline void
+WriteLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock != 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock = -1;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static inline void
+Unlock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ if (ZipFS.lock > 0) {
+ --ZipFS.lock;
+ } else if (ZipFS.lock < 0) {
+ ZipFS.lock = 0;
+ }
+ if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) {
+ Tcl_ConditionNotify(&ZipFSCond);
+ }
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+#else /* !TCL_THREADS */
+#define ReadLock() do {} while (0)
+#define WriteLock() do {} while (0)
+#define Unlock() do {} while (0)
+#endif /* TCL_THREADS */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DosTimeDate, ToDosTime, ToDosDate --
+ *
+ * Functions to perform conversions between DOS time stamps and POSIX
+ * time_t.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static time_t
+DosTimeDate(
+ int dosDate,
+ int dosTime)
+{
+ struct tm tm;
+ time_t ret;
+
+ memset(&tm, 0, sizeof(tm));
+ tm.tm_isdst = -1; /* let mktime() deal with DST */
+ tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80;
+ tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1;
+ tm.tm_mday = dosDate & 0x1f;
+ tm.tm_hour = (dosTime & 0xf800) >> 11;
+ tm.tm_min = (dosTime & 0x7e0) >> 5;
+ tm.tm_sec = (dosTime & 0x1f) << 1;
+ ret = mktime(&tm);
+ if (ret == (time_t) -1) {
+ /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */
+ ret = (time_t) 315532800;
+ }
+ return ret;
+}
+
+static int
+ToDosTime(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !TCL_THREADS || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
+ tmp = localtime(&when);
+ tm = *tmp;
+#elif defined(HAVE_LOCALTIME_R)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1);
+}
+
+static int
+ToDosDate(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !TCL_THREADS || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
+ tmp = localtime(&when);
+ tm = *tmp;
+#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CountSlashes --
+ *
+ * This function counts the number of slashes in a pathname string.
+ *
+ * Results:
+ * Number of slashes found in string.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+CountSlashes(
+ const char *string)
+{
+ int count = 0;
+ const char *p = string;
+
+ while (*p != '\0') {
+ if (*p == '/') {
+ count++;
+ }
+ p++;
+ }
+ return count;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DecodeZipEntryText --
+ *
+ * Given a sequence of bytes from an entry in a ZIP central directory,
+ * convert that into a Tcl string. This is complicated because we don't
+ * actually know what encoding is in use! So we try to use UTF-8, and if
+ * that goes wrong, we fall back to a user-specified encoding, or to an
+ * encoding we specify (Windows code page 437), or to ISO 8859-1 if
+ * absolutely nothing else works.
+ *
+ * During Tcl startup, we skip the user-specified encoding and cp437, as
+ * we may well not have any loadable encodings yet. Tcl's own library
+ * files ought to be using ASCII filenames.
+ *
+ * Results:
+ * The decoded filename; the filename is owned by the argument DString.
+ *
+ * Side effects:
+ * Updates dstPtr.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static char *
+DecodeZipEntryText(
+ const unsigned char *inputBytes,
+ unsigned int inputLength,
+ Tcl_DString *dstPtr)
+{
+ Tcl_Encoding encoding;
+ const char *src;
+ char *dst;
+ int dstLen, srcLen = inputLength, flags;
+ Tcl_EncodingState state;
+
+ Tcl_DStringInit(dstPtr);
+ if (inputLength < 1) {
+ return Tcl_DStringValue(dstPtr);
+ }
+
+ /*
+ * We can't use Tcl_ExternalToUtfDString at this point; it has no way to
+ * fail. So we use this modified version of it that can report encoding
+ * errors to us (so we can fall back to something else).
+ *
+ * The utf-8 encoding is implemented internally, and so is guaranteed to
+ * be present.
+ */
+
+ src = (const char *) inputBytes;
+ dst = Tcl_DStringValue(dstPtr);
+ dstLen = dstPtr->spaceAvl - 1;
+ flags = TCL_ENCODING_START | TCL_ENCODING_END |
+ TCL_ENCODING_STOPONERROR; /* Special flag! */
+
+ while (1) {
+ int srcRead, dstWrote;
+ int result = Tcl_ExternalToUtf(NULL, ZipFS.utf8, src, srcLen, flags,
+ &state, dst, dstLen, &srcRead, &dstWrote, NULL);
+ int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+
+ if (result == TCL_OK) {
+ Tcl_DStringSetLength(dstPtr, soFar);
+ return Tcl_DStringValue(dstPtr);
+ } else if (result != TCL_CONVERT_NOSPACE) {
+ break;
+ }
+
+ flags &= ~TCL_ENCODING_START;
+ src += srcRead;
+ srcLen -= srcRead;
+ if (Tcl_DStringLength(dstPtr) == 0) {
+ Tcl_DStringSetLength(dstPtr, dstLen);
+ }
+ Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
+ dst = Tcl_DStringValue(dstPtr) + soFar;
+ dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
+ }
+
+ /*
+ * Something went wrong. Fall back to another encoding. Those *can* use
+ * Tcl_ExternalToUtfDString().
+ */
+
+ encoding = NULL;
+ if (ZipFS.fallbackEntryEncoding) {
+ encoding = Tcl_GetEncoding(NULL, ZipFS.fallbackEntryEncoding);
+ }
+ if (!encoding) {
+ encoding = Tcl_GetEncoding(NULL, ZIPFS_FALLBACK_ENCODING);
+ }
+ if (!encoding) {
+ /*
+ * Fallback to internal encoding that always converts all bytes.
+ * Should only happen when a filename isn't UTF-8 and we've not got
+ * our encodings initialised for some reason.
+ */
+
+ encoding = Tcl_GetEncoding(NULL, "iso8859-1");
+ }
+
+ char *converted = Tcl_ExternalToUtfDString(encoding,
+ (const char *) inputBytes, inputLength, dstPtr);
+ Tcl_FreeEncoding(encoding);
+ return converted;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CanonicalPath --
+ *
+ * This function computes the canonical path from a directory and file
+ * name components into the specified Tcl_DString.
+ *
+ * Results:
+ * Returns the pointer to the canonical path contained in the specified
+ * Tcl_DString.
+ *
+ * Side effects:
+ * Modifies the specified Tcl_DString.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static char *
+CanonicalPath(
+ const char *root,
+ const char *tail,
+ Tcl_DString *dsPtr,
+ int inZipfs)
+{
+ char *path;
+ int i, j, c, isUNC = 0, isVfs = 0, n = 0;
+ int haveZipfsPath = 1;
+
+#ifdef _WIN32
+ if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') {
+ tail += 2;
+ haveZipfsPath = 0;
+ }
+ /* UNC style path */
+ if (tail[0] == '\\') {
+ root = "";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+ if (tail[0] == '\\') {
+ root = "/";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+#endif /* _WIN32 */
+
+ if (haveZipfsPath) {
+ /* UNC style path */
+ if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 1;
+ } else if (tail &&
+ strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 2;
+ }
+ if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) {
+ isUNC = 1;
+ }
+ }
+
+ if (isVfs != 2) {
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "";
+ }
+ ++tail;
+ isUNC = 0;
+ }
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "/";
+ }
+ ++tail;
+ isUNC = 1;
+ }
+ }
+ i = strlen(root);
+ j = strlen(tail);
+
+ switch (isVfs) {
+ case 1:
+ if (i > ZIPFS_VOLUME_LEN) {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ memcpy(path + i, tail, j);
+ }
+ break;
+ case 2:
+ Tcl_DStringSetLength(dsPtr, j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, tail, j);
+ break;
+ default:
+ if (inZipfs) {
+ Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN);
+ memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ }
+ break;
+ }
+
+#ifdef _WIN32
+ for (i = 0; path[i] != '\0'; i++) {
+ if (path[i] == '\\') {
+ path[i] = '/';
+ }
+ }
+#endif /* _WIN32 */
+
+ if (inZipfs) {
+ n = ZIPFS_VOLUME_LEN;
+ } else {
+ n = 0;
+ }
+
+ for (i = j = n; (c = path[i]) != '\0'; i++) {
+ if (c == '/') {
+ int c2 = path[i + 1];
+
+ if (c2 == '\0' || c2 == '/') {
+ continue;
+ }
+ if (c2 == '.') {
+ int c3 = path[i + 2];
+
+ if ((c3 == '/') || (c3 == '\0')) {
+ i++;
+ continue;
+ }
+ if ((c3 == '.')
+ && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) {
+ i += 2;
+ while ((j > 0) && (path[j - 1] != '/')) {
+ j--;
+ }
+ if (j > isUNC) {
+ --j;
+ while ((j > 1 + isUNC) && (path[j - 2] == '/')) {
+ j--;
+ }
+ }
+ continue;
+ }
+ }
+ }
+ path[j++] = c;
+ }
+ if (j == 0) {
+ path[j++] = '/';
+ }
+ path[j] = 0;
+ Tcl_DStringSetLength(dsPtr, j);
+ return Tcl_DStringValue(dsPtr);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookup --
+ *
+ * This function returns the ZIP entry struct corresponding to the ZIP
+ * archive member of the given file name. Caller must hold the right
+ * lock.
+ *
+ * Results:
+ * Returns the pointer to ZIP entry struct or NULL if the the given file
+ * name could not be found in the global list of ZIP archive members.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipEntry *
+ZipFSLookup(
+ const char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
+ if (hPtr) {
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+ }
+ return z;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookupZip --
+ *
+ * This function gets the structure for a mounted ZIP archive.
+ *
+ * Results:
+ * Returns a pointer to the structure, or NULL if the file is ZIP file is
+ * unknown/not mounted.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipFile *
+ZipFSLookupZip(
+ const char *mountPoint)
+{
+ Tcl_HashEntry *hPtr;
+ ZipFile *zf = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ if (hPtr) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ }
+ return zf;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * AllocateZipFile, AllocateZipEntry, AllocateZipChannel --
+ *
+ * Allocates the memory for a datastructure. Always ensures that it is
+ * zeroed out for safety.
+ *
+ * Returns:
+ * The allocated structure, or NULL if allocate fails.
+ *
+ * Side effects:
+ * The interpreter result may be written to on error. Which might fail
+ * (for ZipFile) in a low-memory situation. Always panics if ZipEntry
+ * allocation fails.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipFile *
+AllocateZipFile(
+ Tcl_Interp *interp,
+ size_t mountPointNameLength)
+{
+ size_t size = sizeof(ZipFile) + mountPointNameLength + 1;
+ ZipFile *zf = (ZipFile *) attemptckalloc(size);
+
+ if (!zf) {
+ ZIPFS_MEM_ERROR(interp);
+ } else {
+ memset(zf, 0, size);
+ }
+ return zf;
+}
+
+static inline ZipEntry *
+AllocateZipEntry(void)
+{
+ ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry));
+ memset(z, 0, sizeof(ZipEntry));
+ return z;
+}
+
+static inline ZipChannel *
+AllocateZipChannel(
+ Tcl_Interp *interp)
+{
+ ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel));
+
+ if (!zc) {
+ ZIPFS_MEM_ERROR(interp);
+ } else {
+ memset(zc, 0, sizeof(ZipChannel));
+ }
+ return zc;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCloseArchive --
+ *
+ * This function closes a mounted ZIP archive file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A memory mapped ZIP archive is unmapped, allocated memory is released.
+ * The ZipFile pointer is *NOT* deallocated by this function.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipFSCloseArchive(
+ Tcl_Interp *interp, /* Current interpreter. */
+ ZipFile *zf)
+{
+ if (zf->nameLength) {
+ ckfree(zf->name);
+ }
+ if (zf->isMemBuffer) {
+ /* Pointer to memory */
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ zf->data = NULL;
+ return;
+ }
+
+ /*
+ * Remove the memory mapping, if we have one.
+ */
+
+#ifdef _WIN32
+ if (zf->data && !zf->ptrToFree) {
+ UnmapViewOfFile(zf->data);
+ zf->data = NULL;
+ }
+ if (zf->mountHandle != INVALID_HANDLE_VALUE) {
+ CloseHandle(zf->mountHandle);
+ }
+#else /* !_WIN32 */
+ if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
+ munmap(zf->data, zf->length);
+ zf->data = (unsigned char *) MAP_FAILED;
+ }
+#endif /* _WIN32 */
+
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ if (zf->chan) {
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFindTOC --
+ *
+ * This function takes a memory mapped zip file and indexes the contents.
+ * When "needZip" is zero an embedded ZIP archive in an executable file
+ * is accepted. Note that we do not support ZIP64.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * The given ZipFile struct is filled with information about the ZIP
+ * archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFindTOC(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i, minoff;
+ const unsigned char *p, *q;
+ const unsigned char *start = zf->data;
+ const unsigned char *end = zf->data + zf->length;
+
+ /*
+ * Scan backwards from the end of the file for the signature. This is
+ * necessary because ZIP archives aren't the only things that get tagged
+ * on the end of executables; digital signatures can also go there.
+ */
+
+ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
+ while (p >= start) {
+ if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) {
+ if (ZipReadInt(start, end, p) == ZIP_CENTRAL_END_SIG) {
+ break;
+ }
+ p -= ZIP_SIG_LEN;
+ } else {
+ --p;
+ }
+ }
+ if (p < zf->data) {
+ /*
+ * Didn't find it (or not enough space for a central directory!); not
+ * a ZIP archive. This might be OK or a problem.
+ */
+
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "wrong end signature");
+ ZIPFS_ERROR_CODE(interp, "END_SIG");
+ goto error;
+ }
+
+ /*
+ * How many files in the archive? If that's bogus, we're done here.
+ */
+
+ zf->numFiles = ZipReadShort(start, end, p + ZIP_CENTRAL_ENTS_OFFS);
+ if (zf->numFiles == 0) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "empty archive");
+ ZIPFS_ERROR_CODE(interp, "EMPTY");
+ goto error;
+ }
+
+ /*
+ * Where does the central directory start?
+ */
+
+ q = zf->data + ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS);
+ p -= ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS);
+ zf->baseOffset = zf->passOffset = (p>q) ? p - q : 0;
+ zf->directoryOffset = q - zf->data + zf->baseOffset;
+ if ((p < q) || (p < zf->data) || (p > zf->data + zf->length)
+ || (q < zf->data) || (q > zf->data + zf->length)) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "archive directory not found");
+ ZIPFS_ERROR_CODE(interp, "NO_DIR");
+ goto error;
+ }
+
+ /*
+ * Read the central directory.
+ */
+
+ q = p;
+ minoff = zf->length;
+ for (i = 0; i < zf->numFiles; i++) {
+ int pathlen, comlen, extra;
+ size_t localhdr_off = zf->length;
+
+ if (q + ZIP_CENTRAL_HEADER_LEN > end) {
+ ZIPFS_ERROR(interp, "wrong header length");
+ ZIPFS_ERROR_CODE(interp, "HDR_LEN");
+ goto error;
+ }
+ if (ZipReadInt(start, end, q) != ZIP_CENTRAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "wrong header signature");
+ ZIPFS_ERROR_CODE(interp, "HDR_SIG");
+ goto error;
+ }
+ pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ localhdr_off = ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if (ZipReadInt(start, end, zf->data + zf->baseOffset + localhdr_off) != ZIP_LOCAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "Failed to find local header");
+ ZIPFS_ERROR_CODE(interp, "LCL_HDR");
+ goto error;
+ }
+ if (localhdr_off < minoff) {
+ minoff = localhdr_off;
+ }
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+
+ zf->passOffset = minoff + zf->baseOffset;
+
+ /*
+ * If there's also an encoded password, extract that too (but don't decode
+ * yet).
+ */
+
+ q = zf->data + zf->passOffset;
+ if ((zf->passOffset >= 6) && (start < q-4) &&
+ (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) {
+ const unsigned char *passPtr;
+
+ i = q[-5];
+ passPtr = q - 5 - i;
+ if (passPtr >= start && passPtr + i < end) {
+ zf->passBuf[0] = i;
+ memcpy(zf->passBuf + 1, passPtr, i);
+ zf->passOffset -= i ? (5 + i) : 0;
+ }
+ }
+
+ return TCL_OK;
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenArchive --
+ *
+ * This function opens a ZIP archive file for reading. An attempt is made
+ * to memory map that file. Otherwise it is read into an allocated memory
+ * buffer. The ZIP archive header is verified and must be valid for the
+ * function to succeed. When "needZip" is zero an embedded ZIP archive in
+ * an executable file is accepted.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * ZIP archive is memory mapped or read into allocated memory, the given
+ * ZipFile struct is filled with information about the ZIP archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSOpenArchive(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *zipname, /* Path to ZIP file to open. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i;
+ void *handle;
+
+ zf->nameLength = 0;
+ zf->isMemBuffer = 0;
+#ifdef _WIN32
+ zf->data = NULL;
+ zf->mountHandle = INVALID_HANDLE_VALUE;
+#else /* !_WIN32 */
+ zf->data = (unsigned char *) MAP_FAILED;
+#endif /* _WIN32 */
+ zf->length = 0;
+ zf->numFiles = 0;
+ zf->baseOffset = zf->passOffset = 0;
+ zf->ptrToFree = NULL;
+ zf->passBuf[0] = 0;
+
+ /*
+ * Actually open the file.
+ */
+
+ zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
+ if (!zf->chan) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * See if we can get the OS handle. If we can, we can use that to memory
+ * map the file, which is nice and efficient. However, it totally depends
+ * on the filename pointing to a real regular OS file.
+ *
+ * Opening real filesystem entities that are not files will lead to an
+ * error.
+ */
+
+ if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) == TCL_OK) {
+ if (ZipMapArchive(interp, zf, handle) != TCL_OK) {
+ goto error;
+ }
+ } else {
+ /*
+ * Not an OS file, but rather something in a Tcl VFS. Must copy into
+ * memory.
+ */
+
+ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ if ((zf->length - ZIP_CENTRAL_END_LEN)
+ > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_ERROR(interp, "illegal file size");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto error;
+ }
+ if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length);
+ if (!zf->ptrToFree) {
+ ZIPFS_MEM_ERROR(interp);
+ goto error;
+ }
+ i = Tcl_Read(zf->chan, (char *) zf->data, zf->length);
+ if (i != zf->length) {
+ ZIPFS_POSIX_ERROR(interp, "file read error");
+ goto error;
+ }
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ }
+ return ZipFSFindTOC(interp, needZip, zf);
+
+ /*
+ * Handle errors by closing the archive. This includes closing the channel
+ * handle for the archive file.
+ */
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipMapArchive --
+ *
+ * Wrapper around the platform-specific parts of mmap() (and Windows's
+ * equivalent) because it's not part of the standard channel API.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipMapArchive(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ ZipFile *zf, /* The archive descriptor structure. */
+ void *handle) /* The OS handle to the open archive. */
+{
+#ifdef _WIN32
+ HANDLE hFile = (HANDLE) handle;
+ int readSuccessful;
+
+ /*
+ * Determine the file size.
+ */
+
+# ifdef _WIN64
+ readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0;
+# else /* !_WIN64 */
+ zf->length = GetFileSize(hFile, 0);
+ readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
+# endif /* _WIN64 */
+ if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Map the file.
+ */
+
+ zf->mountHandle = CreateFileMappingW(hFile, 0, PAGE_READONLY, 0,
+ zf->length, 0);
+ if (zf->mountHandle == INVALID_HANDLE_VALUE) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+ zf->data = (unsigned char *)
+ MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, zf->length);
+ if (!zf->data) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+#else /* !_WIN32 */
+ int fd = PTR2INT(handle);
+
+ /*
+ * Determine the file size.
+ */
+
+ zf->length = lseek(fd, 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ return TCL_ERROR;
+ }
+ lseek(fd, 0, SEEK_SET);
+
+ zf->data = (unsigned char *)
+ mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0);
+ if (zf->data == MAP_FAILED) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+#endif /* _WIN32 */
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * IsPasswordValid --
+ *
+ * Basic test for whether a passowrd is valid. If the test fails, sets an
+ * error message in the interpreter.
+ *
+ * Returns:
+ * TCL_OK if the test passes, TCL_ERROR if it fails.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+IsPasswordValid(
+ Tcl_Interp *interp,
+ const char *passwd,
+ int pwlen)
+{
+ if ((pwlen > 255) || strchr(passwd, 0xff)) {
+ ZIPFS_ERROR(interp, "illegal password");
+ ZIPFS_ERROR_CODE(interp, "BAD_PASS");
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCatalogFilesystem --
+ *
+ * This function generates the root node for a ZIPFS filesystem by
+ * reading the ZIP's central directory.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * Will acquire and release the write lock.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCatalogFilesystem(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ ZipFile *zf, /* Temporary buffer hold archive descriptors */
+ const char *mountPoint, /* Mount point path. */
+ const char *passwd, /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+ const char *zipname) /* Path to ZIP file to build a catalog of. */
+{
+ int pwlen, isNew;
+ size_t i;
+ ZipFile *zf0;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString ds, dsm, fpBuf;
+ unsigned char *q;
+
+ /*
+ * Basic verification of the password for sanity.
+ */
+
+ pwlen = 0;
+ if (passwd) {
+ pwlen = strlen(passwd);
+ if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Validate the TOC data. If that's bad, things fall apart.
+ */
+
+ if (zf->baseOffset >= zf->length || zf->passOffset >= zf->length ||
+ zf->directoryOffset >= zf->length) {
+ ZIPFS_ERROR(interp, "bad zip data");
+ ZIPFS_ERROR_CODE(interp, "BAD_ZIP");
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+
+ WriteLock();
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ Tcl_DStringInit(&ds);
+ Tcl_DStringInit(&dsm);
+ if (strcmp(mountPoint, "/") == 0) {
+ mountPoint = "";
+ } else {
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+ }
+ hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
+ if (!isNew) {
+ if (interp) {
+ zf0 = (ZipFile *) Tcl_GetHashValue(hPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s is already mounted on %s", zf0->name, mountPoint));
+ ZIPFS_ERROR_CODE(interp, "MOUNTED");
+ }
+ Unlock();
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ Unlock();
+
+ /*
+ * Convert to a real archive descriptor.
+ */
+
+ zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ Tcl_CreateExitHandler(ZipfsMountExitHandler, zf);
+ zf->mountPointLen = strlen(zf->mountPoint);
+
+ zf->nameLength = strlen(zipname);
+ zf->name = (char *) ckalloc(zf->nameLength + 1);
+ memcpy(zf->name, zipname, zf->nameLength + 1);
+
+ Tcl_SetHashValue(hPtr, zf);
+ if ((zf->passBuf[0] == 0) && pwlen) {
+ int k = 0;
+
+ zf->passBuf[k++] = pwlen;
+ for (i = pwlen; i-- > 0 ;) {
+ zf->passBuf[k++] = (passwd[i] & 0x0f)
+ | pwrot[(passwd[i] >> 4) & 0x0f];
+ }
+ zf->passBuf[k] = '\0';
+ }
+ if (mountPoint[0] != '\0') {
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
+ if (isNew) {
+ z = AllocateZipEntry();
+ Tcl_SetHashValue(hPtr, z);
+
+ z->depth = CountSlashes(mountPoint);
+ z->zipFilePtr = zf;
+ z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
+ z->offset = zf->baseOffset;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ z->next = zf->entries;
+ zf->entries = z;
+ }
+ }
+ q = zf->data + zf->directoryOffset;
+ Tcl_DStringInit(&fpBuf);
+ for (i = 0; i < zf->numFiles; i++) {
+ const unsigned char *start = zf->data;
+ const unsigned char *end = zf->data + zf->length;
+ int extra, isdir = 0, dosTime, dosDate, nbcompr;
+ size_t offs, pathlen, comlen;
+ unsigned char *lq, *gq = NULL;
+ char *fullpath, *path;
+
+ pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds);
+ if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
+ Tcl_DStringSetLength(&ds, pathlen - 1);
+ path = Tcl_DStringValue(&ds);
+ isdir = 1;
+ }
+ if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
+ goto nextent;
+ }
+ lq = zf->data + zf->baseOffset
+ + ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) {
+ goto nextent;
+ }
+ nbcompr = ZipReadInt(start, end, lq + ZIP_LOCAL_COMPLEN_OFFS);
+ if (!isdir && (nbcompr == 0)
+ && (ZipReadInt(start, end, lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0)
+ && (ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS) == 0)) {
+ gq = q;
+ nbcompr = ZipReadInt(start, end, gq + ZIP_CENTRAL_COMPLEN_OFFS);
+ }
+ offs = (lq - zf->data)
+ + ZIP_LOCAL_HEADER_LEN
+ + ZipReadShort(start, end, lq + ZIP_LOCAL_PATHLEN_OFFS)
+ + ZipReadShort(start, end, lq + ZIP_LOCAL_EXTRALEN_OFFS);
+ if (offs + nbcompr > zf->length) {
+ goto nextent;
+ }
+
+ if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) {
+#ifdef ANDROID
+ /*
+ * When mounting the ZIP archive on the root directory try to
+ * remap top level regular files of the archive to
+ * /assets/.root/... since this directory should not be in a valid
+ * APK due to the leading dot in the file name component. This
+ * trick should make the files AndroidManifest.xml,
+ * resources.arsc, and classes.dex visible to Tcl.
+ */
+ Tcl_DString ds2;
+
+ Tcl_DStringInit(&ds2);
+ Tcl_DStringAppend(&ds2, "assets/.root/", -1);
+ Tcl_DStringAppend(&ds2, path, -1);
+ if (ZipFSLookup(Tcl_DStringValue(&ds2))) {
+ /* should not happen but skip it anyway */
+ Tcl_DStringFree(&ds2);
+ goto nextent;
+ }
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2),
+ Tcl_DStringLength(&ds2));
+ path = Tcl_DStringValue(&ds);
+ Tcl_DStringFree(&ds2);
+#else /* !ANDROID */
+ /*
+ * Regular files skipped when mounting on root.
+ */
+ goto nextent;
+#endif /* ANDROID */
+ }
+
+ Tcl_DStringSetLength(&fpBuf, 0);
+ fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1);
+ z = AllocateZipEntry();
+ z->depth = CountSlashes(fullpath);
+ z->zipFilePtr = zf;
+ z->isDirectory = isdir;
+ z->isEncrypted =
+ (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
+ && (nbcompr > 12);
+ z->offset = offs;
+ if (gq) {
+ z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS);
+ dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS);
+ dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(start, end,
+ gq + ZIP_CENTRAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(start, end,
+ gq + ZIP_CENTRAL_COMPMETH_OFFS);
+ } else {
+ z->crc32 = ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS);
+ dosDate = ZipReadShort(start, end, lq + ZIP_LOCAL_MDATE_OFFS);
+ dosTime = ZipReadShort(start, end, lq + ZIP_LOCAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(start, end,
+ lq + ZIP_LOCAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(start, end,
+ lq + ZIP_LOCAL_COMPMETH_OFFS);
+ }
+ z->numCompressedBytes = nbcompr;
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
+ if (!isNew) {
+ /* should not happen but skip it anyway */
+ ckfree(z);
+ goto nextent;
+ }
+
+ Tcl_SetHashValue(hPtr, z);
+ z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ z->next = zf->entries;
+ zf->entries = z;
+ if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) {
+ z->tnext = zf->topEnts;
+ zf->topEnts = z;
+ }
+
+ /*
+ * Make any directory nodes we need. ZIPs are not consistent about
+ * containing directory nodes.
+ */
+
+ if (!z->isDirectory && (z->depth > 1)) {
+ char *dir, *endPtr;
+ ZipEntry *zd;
+
+ Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, z->name, -1);
+ dir = Tcl_DStringValue(&ds);
+ for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir);
+ endPtr = strrchr(dir, '/')) {
+ Tcl_DStringSetLength(&ds, endPtr - dir);
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
+ if (!isNew) {
+ /*
+ * Already made. That's fine.
+ */
+ break;
+ }
+
+ zd = AllocateZipEntry();
+ zd->depth = CountSlashes(dir);
+ zd->zipFilePtr = zf;
+ zd->isDirectory = 1;
+ zd->offset = z->offset;
+ zd->timestamp = z->timestamp;
+ zd->compressMethod = ZIP_COMPMETH_STORED;
+ Tcl_SetHashValue(hPtr, zd);
+ zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ zd->next = zf->entries;
+ zf->entries = zd;
+ if ((mountPoint[0] == '\0') && (zd->depth == 1)) {
+ zd->tnext = zf->topEnts;
+ zf->topEnts = zd;
+ }
+ }
+ }
+ nextent:
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ Tcl_DStringFree(&fpBuf);
+ Tcl_DStringFree(&ds);
+ Tcl_FSMountsChanged(NULL);
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipfsSetup --
+ *
+ * Common initialisation code. ZipFS.initialized must *not* be set prior
+ * to the call.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipfsSetup(void)
+{
+#if TCL_THREADS
+ static const Tcl_Time t = { 0, 0 };
+
+ /*
+ * Inflate condition variable.
+ */
+
+ Tcl_MutexLock(&ZipFSMutex);
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
+ Tcl_MutexUnlock(&ZipFSMutex);
+#endif /* TCL_THREADS */
+
+ crc32tab = get_crc_table();
+ Tcl_FSRegister(NULL, &zipfsFilesystem);
+ Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
+ ZipFS.idCount = 1;
+ ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE;
+ ZipFS.fallbackEntryEncoding = (char *)
+ ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1);
+ strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING);
+ ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8");
+ ZipFS.initialized = 1;
+ Tcl_CreateExitHandler(ZipfsExitHandler, NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ListMountPoints --
+ *
+ * This procedure lists the mount points and what's mounted there, or
+ * reports whether there are any mounts (if there's no interpreter). The
+ * read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no
+ * interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+ListMountPoints(
+ Tcl_Interp *interp)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ ZipFile *zf;
+ Tcl_Obj *resultList;
+
+ if (!interp) {
+ /*
+ * Are there any entries in the zipHash? Don't need to enumerate them
+ * all to know.
+ */
+
+ return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK);
+ }
+
+ resultList = Tcl_NewObj();
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
+ zf->mountPoint, -1));
+ Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
+ zf->name, -1));
+ }
+ Tcl_SetObjResult(interp, resultList);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DescribeMounted --
+ *
+ * This procedure describes what is mounted at the given the mount point.
+ * The interpreter result is not updated if there is nothing mounted at
+ * the given point. The read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there
+ * and no interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+DescribeMounted(
+ Tcl_Interp *interp,
+ const char *mountPoint)
+{
+ if (interp) {
+ ZipFile *zf = ZipFSLookupZip(mountPoint);
+
+ if (zf) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
+ return TCL_OK;
+ }
+ }
+ return (interp ? TCL_OK : TCL_BREAK);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint with optional ZIP password.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ const char *zipname, /* Path to ZIP file to mount; should be
+ * normalized. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZipFile *zf;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no file, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!zipname) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and a file (name) to mount there.
+ */
+
+ if (passwd && IsPasswordValid(interp, passwd, strlen(passwd)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (!zf) {
+ return TCL_ERROR;
+ }
+ if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_MountBuffer --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint with optional ZIP password.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ unsigned char *data,
+ size_t datalen,
+ int copy)
+{
+ ZipFile *zf;
+ int result;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no data, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!data) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and data to mount there.
+ */
+
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (!zf) {
+ return TCL_ERROR;
+ }
+ zf->isMemBuffer = 1;
+ zf->length = datalen;
+ if (copy) {
+ zf->data = (unsigned char *) attemptckalloc(datalen);
+ if (!zf->data) {
+ ZIPFS_MEM_ERROR(interp);
+ return TCL_ERROR;
+ }
+ memcpy(zf->data, data, datalen);
+ zf->ptrToFree = zf->data;
+ } else {
+ zf->data = data;
+ zf->ptrToFree = NULL;
+ }
+ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
+ "Memory Buffer");
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Unmount --
+ *
+ * This procedure is invoked to unmount a given ZIP archive.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A mounted ZIP archive file is unmounted, resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint) /* Mount point path. */
+{
+ ZipFile *zf;
+ ZipEntry *z, *znext;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString dsm;
+ int ret = TCL_OK, unmounted = 0;
+
+ WriteLock();
+ if (!ZipFS.initialized) {
+ goto done;
+ }
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ Tcl_DStringInit(&dsm);
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ /* don't report no-such-mount as an error */
+ if (!hPtr) {
+ goto done;
+ }
+
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ if (zf->numOpen > 0) {
+ ZIPFS_ERROR(interp, "filesystem is busy");
+ ZIPFS_ERROR_CODE(interp, "BUSY");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * Now no longer mounted - the rest of the code won't find it - but we're
+ * still cleaning things up.
+ */
+
+ for (z = zf->entries; z; z = znext) {
+ znext = z->next;
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ if (z->data) {
+ ckfree(z->data);
+ }
+ ckfree(z);
+ }
+ ZipFSCloseArchive(interp, zf);
+ Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf);
+ ckfree(zf);
+ unmounted = 1;
+
+ done:
+ Unlock();
+ if (unmounted) {
+ Tcl_FSMountsChanged(NULL);
+ }
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is mounted, resources are allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMountObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mountPoint = NULL, *zipFile = NULL, *password = NULL;
+ Tcl_Obj *zipFileObj = NULL;
+ int result;
+
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?mountpoint? ?zipfile? ?password?");
+ return TCL_ERROR;
+ }
+ if (objc > 1) {
+ mountPoint = Tcl_GetString(objv[1]);
+ }
+ if (objc > 2) {
+ zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (!zipFileObj) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "could not normalize zip filename", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(zipFileObj);
+ zipFile = Tcl_GetString(zipFileObj);
+ }
+ if (objc > 3) {
+ password = Tcl_GetString(objv[3]);
+ }
+
+ result = TclZipfs_Mount(interp, mountPoint, zipFile, password);
+ if (zipFileObj != NULL) {
+ Tcl_DecrRefCount(zipFileObj);
+ }
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountBufferObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount_data] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is mounted, resources are allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMountBufferObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mountPoint; /* Mount point path. */
+ unsigned char *data;
+ int length;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
+ return TCL_ERROR;
+ }
+ if (objc < 2) {
+ int ret;
+
+ ReadLock();
+ ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ mountPoint = Tcl_GetString(objv[1]);
+ if (objc < 3) {
+ ReadLock();
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+
+ data = TclGetBytesFromObj(interp, objv[2], &length);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
+ return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSRootObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs root] command. It
+ * returns the root that all zipfs file systems are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSRootObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
+{
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSUnmountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs unmount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A mounted ZIP archive file is unmounted, resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSUnmountObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
+ return TCL_ERROR;
+ }
+ return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkKeyObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mkkey] command. It
+ * produces a rotated password to be embedded into an image file.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkKeyObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int len, i = 0;
+ const char *pw;
+ Tcl_Obj *passObj;
+ unsigned char *passBuf;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "password");
+ return TCL_ERROR;
+ }
+ pw = Tcl_GetStringFromObj(objv[1], &len);
+ if (len == 0) {
+ return TCL_OK;
+ }
+ if (IsPasswordValid(interp, pw, len) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ passObj = Tcl_NewByteArrayObj(NULL, 264);
+ passBuf = Tcl_GetByteArrayFromObj(passObj, (int *)NULL);
+ while (len > 0) {
+ int ch = pw[len - 1];
+
+ passBuf[i++] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ len--;
+ }
+ passBuf[i] = i;
+ i++;
+ ZipWriteInt(passBuf, passBuf + 264, passBuf + i, ZIP_PASSWORD_END_SIG);
+ Tcl_SetByteArrayLength(passObj, i + 4);
+ Tcl_SetObjResult(interp, passObj);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * RandomChar --
+ *
+ * Worker for ZipAddFile(). Picks a random character (range: 0..255)
+ * using Tcl's standard PRNG.
+ *
+ * Returns:
+ * Tcl result code. Updates chPtr with random character on success.
+ *
+ * Side effects:
+ * Advances the PRNG state. May reenter the Tcl interpreter if the user
+ * has replaced the PRNG.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+RandomChar(
+ Tcl_Interp *interp,
+ int step,
+ int *chPtr)
+{
+ double r;
+ Tcl_Obj *ret;
+
+ if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) {
+ goto failed;
+ }
+ ret = Tcl_GetObjResult(interp);
+ if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) {
+ goto failed;
+ }
+ *chPtr = (int) (r * 256);
+ return TCL_OK;
+
+ failed:
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ step));
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipAddFile --
+ *
+ * This procedure is used by ZipFSMkZipOrImg() to add a single file to
+ * the output ZIP archive file being written. A ZipEntry struct about the
+ * input file is added to the given fileHash table for later creation of
+ * the central ZIP directory.
+ *
+ * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it
+ * would always encode comments as UTF-8, if it supported comments.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Input file is read and (compressed and) written to the output ZIP
+ * archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipAddFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathObj, /* Actual name of the file to add. */
+ const char *name, /* Name to use in the ZIP archive, in Tcl's
+ * internal encoding. */
+ Tcl_Channel out, /* The open ZIP archive being built. */
+ const char *passwd, /* Password for encoding the file, or NULL if
+ * the file is to be unprotected. */
+ char *buf, /* Working buffer. */
+ int bufsize, /* Size of buf */
+ Tcl_HashTable *fileHash) /* Where to record ZIP entry metdata so we can
+ * built the central directory. */
+{
+ const unsigned char *start = (unsigned char *) buf;
+ const unsigned char *end = (unsigned char *) buf + bufsize;
+ Tcl_Channel in;
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z;
+ z_stream stream;
+ Tcl_DString zpathDs; /* Buffer for the encoded filename. */
+ const char *zpathExt; /* Filename in external encoding (true
+ * UTF-8). */
+ const char *zpathTcl; /* Filename in Tcl's internal encoding. */
+ int crc, flush, zpathlen;
+ size_t nbyte, nbytecompr, len, olen, align = 0;
+ long long headerStartOffset, dataStartOffset, dataEndOffset;
+ int mtime = 0, isNew, compMeth;
+ unsigned long keys[3], keys0[3];
+ char obuf[4096];
+
+ /*
+ * Trim leading '/' characters. If this results in an empty string, we've
+ * nothing to do.
+ */
+
+ zpathTcl = name;
+ while (zpathTcl && zpathTcl[0] == '/') {
+ zpathTcl++;
+ }
+ if (!zpathTcl || (zpathTcl[0] == '\0')) {
+ return TCL_OK;
+ }
+
+ /*
+ * Convert to encoded form. Note that we use strlen() here; if someone's
+ * crazy enough to embed NULs in filenames, they deserve what they get!
+ */
+
+ zpathExt = Tcl_UtfToExternalDString(ZipFS.utf8, zpathTcl, -1, &zpathDs);
+ zpathlen = strlen(zpathExt);
+ if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "path too long for \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "PATH_LEN");
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0);
+ if (!in) {
+ Tcl_DStringFree(&zpathDs);
+#ifdef _WIN32
+ /* hopefully a directory */
+ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+#endif /* _WIN32 */
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ } else {
+ Tcl_StatBuf statBuf;
+
+ if (Tcl_FSStat(pathObj, &statBuf) != -1) {
+ mtime = statBuf.st_mtime;
+ }
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ * Compute the CRC.
+ */
+
+ crc = 0;
+ nbyte = nbytecompr = 0;
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_DStringFree(&zpathDs);
+ if (nbyte == 0 && errno == EISDIR) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+ readErrorWithChannelOpen:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ if (len == 0) {
+ break;
+ }
+ crc = crc32(crc, (unsigned char *) buf, len);
+ nbyte += len;
+ }
+ if (Tcl_Seek(in, 0, SEEK_SET) == -1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remember where we've got to so far so we can write the header (after
+ * writing the file).
+ */
+
+ headerStartOffset = Tcl_Tell(out);
+
+ /*
+ * Reserve space for the per-file header. Includes writing the file name
+ * as we already know that.
+ */
+
+ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
+ memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen);
+ len = zpathlen + ZIP_LOCAL_HEADER_LEN;
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ writeErrorWithChannelOpen:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Align payload to next 4-byte boundary (if necessary) using a dummy
+ * extra entry similar to the zipalign tool from Android's SDK.
+ */
+
+ if ((len + headerStartOffset) & 3) {
+ unsigned char abuf[8];
+ const unsigned char *astart = abuf;
+ const unsigned char *aend = abuf + 8;
+
+ align = 4 + ((len + headerStartOffset) & 3);
+ ZipWriteShort(astart, aend, abuf, 0xffff);
+ ZipWriteShort(astart, aend, abuf + 2, align - 4);
+ ZipWriteInt(astart, aend, abuf + 4, 0x03020100);
+ if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) {
+ goto writeErrorWithChannelOpen;
+ }
+ }
+
+ /*
+ * Set up encryption if we were asked to.
+ */
+
+ if (passwd) {
+ int i, ch, tmp;
+ unsigned char kvbuf[24];
+
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ if (RandomChar(interp, i, &ch) != TCL_OK) {
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp));
+ }
+ Tcl_ResetResult(interp);
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], tmp));
+ }
+ kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
+ kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
+ len = Tcl_Write(out, (char *) kvbuf, 12);
+ memset(kvbuf, 0, 24);
+ if (len != 12) {
+ goto writeErrorWithChannelOpen;
+ }
+ memcpy(keys0, keys, sizeof(keys0));
+ nbytecompr += 12;
+ }
+
+ /*
+ * Save where we've got to in case we need to just store this file.
+ */
+
+ Tcl_Flush(out);
+ dataStartOffset = Tcl_Tell(out);
+
+ /*
+ * Compress the stream.
+ */
+
+ compMeth = ZIP_COMPMETH_DEFLATED;
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8,
+ Z_DEFAULT_STRATEGY) != Z_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "compression init error on \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT");
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ do {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ deflateEnd(&stream);
+ goto readErrorWithChannelOpen;
+ }
+ stream.avail_in = len;
+ stream.next_in = (unsigned char *) buf;
+ flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
+ do {
+ stream.avail_out = sizeof(obuf);
+ stream.next_out = (unsigned char *) obuf;
+ len = deflate(&stream, flush);
+ if (len == (size_t) Z_STREAM_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "deflate error on \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DEFLATE");
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ olen = sizeof(obuf) - stream.avail_out;
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < olen; i++) {
+ obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
+ }
+ }
+ if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) {
+ deflateEnd(&stream);
+ goto writeErrorWithChannelOpen;
+ }
+ nbytecompr += olen;
+ } while (stream.avail_out == 0);
+ } while (flush != Z_FINISH);
+ deflateEnd(&stream);
+
+ /*
+ * Work out where we've got to.
+ */
+
+ Tcl_Flush(out);
+ dataEndOffset = Tcl_Tell(out);
+
+ if (nbyte - nbytecompr <= 0) {
+ /*
+ * Compressed file larger than input, write it again uncompressed.
+ */
+
+ if (Tcl_Seek(in, 0, SEEK_SET) != 0) {
+ goto seekErr;
+ }
+ if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) {
+ seekErr:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ nbytecompr = (passwd ? 12 : 0);
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ goto readErrorWithChannelOpen;
+ } else if (len == 0) {
+ break;
+ }
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < len; i++) {
+ buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
+ }
+ }
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ goto writeErrorWithChannelOpen;
+ }
+ nbytecompr += len;
+ }
+ compMeth = ZIP_COMPMETH_STORED;
+
+ /*
+ * Chop off everything after this; it's the over-large compressed data
+ * and we don't know if it is going to get overwritten otherwise.
+ */
+
+ Tcl_Flush(out);
+ dataEndOffset = Tcl_Tell(out);
+ Tcl_TruncateChannel(out, dataEndOffset);
+ }
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ zpathExt = NULL;
+
+ hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "non-unique path name \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DUPLICATE_PATH");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remember that we've written the file (for central directory generation)
+ * and generate the local (per-file) header in the space that we reserved
+ * earlier.
+ */
+
+ z = AllocateZipEntry();
+ Tcl_SetHashValue(hPtr, z);
+ z->isEncrypted = (passwd ? 1 : 0);
+ z->offset = headerStartOffset;
+ z->crc32 = crc;
+ z->timestamp = mtime;
+ z->numBytes = nbyte;
+ z->numCompressedBytes = nbytecompr;
+ z->compressMethod = compMeth;
+ z->name = (char *) Tcl_GetHashKey(fileHash, hPtr);
+
+ /*
+ * Write final local header information.
+ */
+
+ SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z,
+ zpathlen, align);
+ if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ Tcl_Flush(out);
+ if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFind --
+ *
+ * Worker for ZipFSMkZipOrImg() that discovers the list of files to add.
+ * Simple wrapper around [zipfs find].
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFind(
+ Tcl_Interp *interp,
+ Tcl_Obj *dirRoot)
+{
+ Tcl_Obj *cmd[2];
+ int result;
+
+ cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
+ cmd[1] = dirRoot;
+ Tcl_IncrRefCount(cmd[0]);
+ result = Tcl_EvalObjv(interp, 2, cmd, 0);
+ Tcl_DecrRefCount(cmd[0]);
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ComputeNameInArchive --
+ *
+ * Helper for ZipFSMkZipOrImg() that computes what the actual name of a
+ * file in the ZIP archive should be, stripping a prefix (if appropriate)
+ * and any leading slashes. If the result is an empty string, the entry
+ * should be skipped.
+ *
+ * Returns:
+ * Pointer to the name (in Tcl's internal encoding), which will be in
+ * memory owned by one of the argument objects.
+ *
+ * Side effects:
+ * None (if Tcl_Objs have string representations)
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline const char *
+ComputeNameInArchive(
+ Tcl_Obj *pathObj, /* The path to the origin file */
+ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
+ * archive */
+ const char *strip, /* A prefix to strip; may be NULL if no
+ * stripping need be done. */
+ int slen) /* The length of the prefix; must be 0 if no
+ * stripping need be done. */
+{
+ const char *name;
+ int len;
+
+ if (directNameObj) {
+ name = Tcl_GetString(directNameObj);
+ } else {
+ name = Tcl_GetStringFromObj(pathObj, &len);
+ if (slen > 0) {
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ /*
+ * Guaranteed to be a NUL at the end, which will make this
+ * entry be skipped.
+ */
+
+ return name + len;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ return name;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipOrImg --
+ *
+ * This procedure is creates a new ZIP archive file or image file given
+ * output filename, input directory of files to be archived, optional
+ * password, and optional image to be prepended to the output ZIP archive
+ * file. It's the core of the implementation of [zipfs mkzip], [zipfs
+ * mkimg], [zipfs lmkzip] and [zipfs lmkimg].
+ *
+ * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it
+ * would always encode comments as UTF-8, if it supported comments.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A new ZIP archive file or image file is written.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipOrImg(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int isImg, /* Are we making an image? */
+ Tcl_Obj *targetFile, /* What file are we making? */
+ Tcl_Obj *dirRoot, /* What directory do we take files from? Do
+ * not specify at the same time as
+ * mappingList (one must be NULL). */
+ Tcl_Obj *mappingList, /* What files are we putting in, and with what
+ * names? Do not specify at the same time as
+ * dirRoot (one must be NULL). */
+ Tcl_Obj *originFile, /* If we're making an image, what file does
+ * the non-ZIP part of the image come from? */
+ Tcl_Obj *stripPrefix, /* Are we going to strip a prefix from
+ * filenames found beneath dirRoot? If NULL,
+ * do not strip anything (except for dirRoot
+ * itself). */
+ Tcl_Obj *passwordObj) /* The password for encoding things. NULL if
+ * there's no password protection. */
+{
+ Tcl_Channel out;
+ int pwlen = 0, slen = 0, count, ret = TCL_ERROR, lobjc;
+ size_t len, i = 0;
+ long long directoryStartOffset;
+ /* The overall file offset of the start of the
+ * central directory. */
+ long long suffixStartOffset;/* The overall file offset of the start of the
+ * suffix of the central directory (i.e.,
+ * where this data will be written). */
+ Tcl_Obj **lobjv, *list = mappingList;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_HashTable fileHash;
+ char *strip = NULL, *pw = NULL, passBuf[264], buf[4096];
+ unsigned char *start = (unsigned char *) buf;
+ unsigned char *end = start + sizeof(buf);
+
+ /*
+ * Caller has verified that the number of arguments is correct.
+ */
+
+ passBuf[0] = 0;
+ if (passwordObj != NULL) {
+ pw = Tcl_GetStringFromObj(passwordObj, &pwlen);
+ if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (pwlen <= 0) {
+ pw = NULL;
+ pwlen = 0;
+ }
+ }
+ if (dirRoot != NULL) {
+ list = ZipFSFind(interp, dirRoot);
+ if (!list) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_IncrRefCount(list);
+ if (TclListObjLengthM(interp, list, &lobjc) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ if (mappingList && (lobjc % 2)) {
+ Tcl_DecrRefCount(list);
+ ZIPFS_ERROR(interp, "need even number of elements");
+ ZIPFS_ERROR_CODE(interp, "LIST_LENGTH");
+ return TCL_ERROR;
+ }
+ if (lobjc == 0) {
+ Tcl_DecrRefCount(list);
+ ZIPFS_ERROR(interp, "empty archive");
+ ZIPFS_ERROR_CODE(interp, "EMPTY");
+ return TCL_ERROR;
+ }
+ if (TclListObjGetElementsM(interp, list, &lobjc, &lobjv) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ out = Tcl_FSOpenFileChannel(interp, targetFile, "wb", 0755);
+ if (out == NULL) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Copy the existing contents from the image if it is an executable image.
+ * Care must be taken because this might include an existing ZIP, which
+ * needs to be stripped.
+ */
+
+ if (isImg) {
+ ZipFile *zf, zf0;
+ int isMounted = 0;
+ const char *imgName;
+
+ // TODO: normalize the origin file name
+ imgName = (originFile != NULL) ? Tcl_GetString(originFile) :
+ Tcl_GetNameOfExecutable();
+ if (pwlen) {
+ i = 0;
+ for (len = pwlen; len-- > 0;) {
+ int ch = pw[len];
+
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ i++;
+ }
+ passBuf[i] = i;
+ ++i;
+ passBuf[i++] = (char) ZIP_PASSWORD_END_SIG;
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
+ passBuf[i] = '\0';
+ }
+
+ /*
+ * Check for mounted image.
+ */
+
+ WriteLock();
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ if (strcmp(zf->name, imgName) == 0) {
+ isMounted = 1;
+ zf->numOpen++;
+ break;
+ }
+ }
+ Unlock();
+
+ if (!isMounted) {
+ zf = &zf0;
+ memset(&zf0, 0, sizeof(ZipFile));
+ }
+ if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
+ /*
+ * Copy everything up to the ZIP-related suffix.
+ */
+
+ if ((size_t) Tcl_Write(out, (char *) zf->data,
+ zf->passOffset) != zf->passOffset) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ return TCL_ERROR;
+ }
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ } else {
+ /*
+ * Fall back to read it as plain file which hopefully is a static
+ * tclsh or wish binary with proper zipfs infrastructure built in.
+ */
+
+ if (CopyImageFile(interp, imgName, out) != TCL_OK) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Store the password so that the automounter can find it.
+ */
+
+ len = strlen(passBuf);
+ if (len > 0) {
+ i = Tcl_Write(out, passBuf, len);
+ if (i != len) {
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ }
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_Flush(out);
+ }
+
+ /*
+ * Prepare the contents of the ZIP archive.
+ */
+
+ Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
+ if (mappingList == NULL && stripPrefix != NULL) {
+ strip = Tcl_GetStringFromObj(stripPrefix, &slen);
+ if (!slen) {
+ strip = NULL;
+ }
+ }
+ for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) {
+ Tcl_Obj *pathObj = lobjv[i];
+ const char *name = ComputeNameInArchive(pathObj,
+ (mappingList ? lobjv[i + 1] : NULL), strip, slen);
+
+ if (name[0] == '\0') {
+ continue;
+ }
+ if (ZipAddFile(interp, pathObj, name, out, pw, buf, sizeof(buf),
+ &fileHash) != TCL_OK) {
+ goto done;
+ }
+ }
+
+ /*
+ * Construct the contents of the ZIP central directory.
+ */
+
+ directoryStartOffset = Tcl_Tell(out);
+ count = 0;
+ for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) {
+ const char *name = ComputeNameInArchive(lobjv[i],
+ (mappingList ? lobjv[i + 1] : NULL), strip, slen);
+ Tcl_DString ds;
+
+ hPtr = Tcl_FindHashEntry(&fileHash, name);
+ if (!hPtr) {
+ continue;
+ }
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ name = Tcl_UtfToExternalDString(ZipFS.utf8, z->name, -1, &ds);
+ len = Tcl_DStringLength(&ds);
+ SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf,
+ z, len);
+ if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN)
+ != ZIP_CENTRAL_HEADER_LEN)
+ || ((size_t) Tcl_Write(out, name, len) != len)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_DStringFree(&ds);
+ goto done;
+ }
+ Tcl_DStringFree(&ds);
+ count++;
+ }
+
+ /*
+ * Finalize the central directory.
+ */
+
+ Tcl_Flush(out);
+ suffixStartOffset = Tcl_Tell(out);
+ SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf,
+ count, directoryStartOffset, suffixStartOffset);
+ if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ goto done;
+ }
+ Tcl_Flush(out);
+ ret = TCL_OK;
+
+ done:
+ if (ret == TCL_OK) {
+ ret = Tcl_Close(interp, out);
+ } else {
+ Tcl_Close(interp, out);
+ }
+ Tcl_DecrRefCount(list);
+ for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+ ckfree(z);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&fileHash);
+ return ret;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * CopyImageFile --
+ *
+ * A simple file copy function that is used (by ZipFSMkZipOrImg) for
+ * anything that is not an image with a ZIP appended.
+ *
+ * Returns:
+ * A Tcl result code.
+ *
+ * Side effects:
+ * Writes to an output channel.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static int
+CopyImageFile(
+ Tcl_Interp *interp, /* For error reporting. */
+ const char *imgName, /* Where to copy from. */
+ Tcl_Channel out) /* Where to copy to; already open for writing
+ * binary data. */
+{
+ size_t i, k;
+ int m, n;
+ Tcl_Channel in;
+ char buf[4096];
+ const char *errMsg;
+
+ Tcl_ResetResult(interp);
+ in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644);
+ if (!in) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the length of the file (and exclude non-files).
+ */
+
+ i = Tcl_Seek(in, 0, SEEK_END);
+ if (i == ERROR_LENGTH) {
+ errMsg = "seek error";
+ goto copyError;
+ }
+ Tcl_Seek(in, 0, SEEK_SET);
+
+ /*
+ * Copy the whole file, 8 blocks at a time (reasonably efficient). Note
+ * that this totally ignores things like Windows's Alternate File Streams.
+ */
+
+ for (k = 0; k < i; k += m) {
+ m = i - k;
+ if (m > (int) sizeof(buf)) {
+ m = (int) sizeof(buf);
+ }
+ n = Tcl_Read(in, buf, m);
+ if (n == -1) {
+ errMsg = "read error";
+ goto copyError;
+ } else if (n == 0) {
+ break;
+ }
+ m = Tcl_Write(out, buf, n);
+ if (m != n) {
+ errMsg = "write error";
+ goto copyError;
+ }
+ }
+ Tcl_Close(interp, in);
+ return TCL_OK;
+
+ copyError:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s: %s", errMsg, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * SerializeLocalEntryHeader, SerializeCentralDirectoryEntry,
+ * SerializeCentralDirectorySuffix --
+ *
+ * Create serialized forms of the structures that make up the ZIP
+ * metadata. Note that the both the local entry and the central directory
+ * entry need to have the name of the entry written directly afterwards.
+ *
+ * We could write these as structs except we need to guarantee that we
+ * are writing these out as little-endian values.
+ *
+ * Side effects:
+ * Both update their buffer arguments, but otherwise change nothing.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static void
+SerializeLocalEntryHeader(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ ZipEntry *z, /* The description of what to serialize. */
+ int nameLength, /* The length of the name. */
+ int align) /* The number of alignment bytes. */
+{
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS,
+ z->compressMethod);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS,
+ ToDosTime(z->timestamp));
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS,
+ ToDosDate(z->timestamp));
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_COMPLEN_OFFS,
+ z->numCompressedBytes);
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_PATHLEN_OFFS, nameLength);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
+}
+
+static void
+SerializeCentralDirectoryEntry(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ ZipEntry *z, /* The description of what to serialize. */
+ size_t nameLength) /* The length of the name. */
+{
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS,
+ ZIP_CENTRAL_HEADER_SIG);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS,
+ ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS,
+ z->compressMethod);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS,
+ ToDosTime(z->timestamp));
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS,
+ ToDosDate(z->timestamp));
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_COMPLEN_OFFS,
+ z->numCompressedBytes);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_PATHLEN_OFFS, nameLength);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS,
+ z->offset);
+}
+
+static void
+SerializeCentralDirectorySuffix(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ int entryCount, /* The number of entries in the directory */
+ long long directoryStartOffset,
+ /* The overall file offset of the start of the
+ * central directory. */
+ long long suffixStartOffset)/* The overall file offset of the start of the
+ * suffix of the central directory (i.e.,
+ * where this data will be written). */
+{
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_END_SIG_OFFS,
+ ZIP_CENTRAL_END_SIG);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_ENTS_OFFS, entryCount);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_TOTALENTS_OFFS, entryCount);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS,
+ suffixStartOffset - directoryStartOffset);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS,
+ directoryStartOffset);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkzip] and [zipfs
+ * lmkzip] commands. See description of ZipFSMkZipOrImg().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImg().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *stripPrefix, *password;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ stripPrefix = (objc > 3 ? objv[3] : NULL);
+ password = (objc > 4 ? objv[4] : NULL);
+ return ZipFSMkZipOrImg(interp, 0, objv[1], objv[2], NULL, NULL,
+ stripPrefix, password);
+}
+
+static int
+ZipFSLMkZipObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *password;
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ password = (objc > 3 ? objv[3] : NULL);
+ return ZipFSMkZipOrImg(interp, 0, objv[1], NULL, objv[2], NULL,
+ NULL, password);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkimg] and [zipfs
+ * lmkimg] commands. See description of ZipFSMkZipOrImg().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImg().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkImgObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *originFile, *stripPrefix, *password;
+
+ if (objc < 3 || objc > 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "outfile indir ?strip? ?password? ?infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ originFile = (objc > 5 ? objv[5] : NULL);
+ stripPrefix = (objc > 3 ? objv[3] : NULL);
+ password = (objc > 4 ? objv[4] : NULL);
+ return ZipFSMkZipOrImg(interp, 1, objv[1], objv[2], NULL,
+ originFile, stripPrefix, password);
+}
+
+static int
+ZipFSLMkImgObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *originFile, *password;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ originFile = (objc > 4 ? objv[4] : NULL);
+ password = (objc > 3 ? objv[3] : NULL);
+ return ZipFSMkZipOrImg(interp, 1, objv[1], NULL, objv[2],
+ originFile, NULL, password);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCanonicalObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs canonical] command.
+ * It returns the canonical name for a file within zipfs
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCanonicalObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *mntpoint = NULL;
+ char *filename = NULL;
+ char *result;
+ Tcl_DString dPath;
+
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?");
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&dPath);
+ if (objc == 2) {
+ filename = Tcl_GetString(objv[1]);
+ result = CanonicalPath("", filename, &dPath, 1);
+ } else if (objc == 3) {
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, 1);
+ } else {
+ int zipfs = 0;
+
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
+ return TCL_ERROR;
+ }
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSExistsObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs exists] command. It
+ * tests for the existence of a file in the ZIP filesystem and places a
+ * boolean into the interp's result.
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSExistsObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ int exists;
+ Tcl_DString ds;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Prepend ZIPFS_VOLUME to filename, eliding the final /
+ */
+
+ filename = Tcl_GetString(objv[1]);
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
+ Tcl_DStringAppend(&ds, filename, -1);
+ filename = Tcl_DStringValue(&ds);
+
+ ReadLock();
+ exists = ZipFSLookup(filename) != NULL;
+ Unlock();
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSInfoObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs info] command. On
+ * success, it returns a Tcl list made up of name of ZIP archive file,
+ * size uncompressed, size compressed, and archive offset of a file in
+ * the ZIP filesystem.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSInfoObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ ZipEntry *z;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+ filename = Tcl_GetString(objv[1]);
+ ReadLock();
+ z = ZipFSLookup(filename);
+ if (z) {
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->zipFilePtr->name, -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numBytes));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numCompressedBytes));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
+ }
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs list] command. On
+ * success, it returns a Tcl list of files of the ZIP filesystem which
+ * match a search pattern (glob or regexp).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSListObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *pattern = NULL;
+ Tcl_RegExp regexp = NULL;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+ const char *options[] = {"-glob", "-regexp", NULL};
+ enum list_options { OPT_GLOB, OPT_REGEXP };
+
+ /*
+ * Parse arguments.
+ */
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ int idx;
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option",
+ 0, &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case OPT_GLOB:
+ pattern = Tcl_GetString(objv[2]);
+ break;
+ case OPT_REGEXP:
+ regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
+ if (!regexp) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ } else if (objc == 2) {
+ pattern = Tcl_GetString(objv[1]);
+ }
+
+ /*
+ * Scan for matching entries.
+ */
+
+ ReadLock();
+ if (pattern) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if (Tcl_StringMatch(z->name, pattern)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else if (regexp) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_TclLibrary --
+ *
+ * This procedure gets (and possibly finds) the root that Tcl's library
+ * files are mounted under.
+ *
+ * Results:
+ * A Tcl object holding the location (with zero refcount), or NULL if no
+ * Tcl library can be found.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(STATIC_BUILD)
+# define LIBRARY_SIZE 64
+ HMODULE hModule;
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char dllName[(MAX_PATH + LIBRARY_SIZE) * 3];
+#endif /* _WIN32 */
+
+ /*
+ * Use the cached value if that has been set; we don't want to repeat the
+ * searching and mounting.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * Look for the library file system within the executable.
+ */
+
+ vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
+ -1);
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * Look for the library file system within the DLL/shared library. Note
+ * that we must mount the zip file and dll before releasing to search.
+ */
+
+#if !defined(STATIC_BUILD)
+#if defined(_WIN32) || defined(__CYGWIN__)
+ hModule = (HMODULE)TclWinGetTclInstance();
+ GetModuleFileNameW(hModule, wName, MAX_PATH);
+#ifdef __CYGWIN__
+ cygwin_conv_path(3, wName, dllName, sizeof(dllName));
+#else
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
+#endif
+
+ if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#elif !defined(NO_DLFCN_H)
+ Dl_info dlinfo;
+ if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
+ && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#else
+ if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#endif /* _WIN32 */
+#endif /* !defined(STATIC_BUILD) */
+
+ /*
+ * If anything set the cache (but subsequently failed) go with that
+ * anyway.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSTclLibraryObjCmd --
+ *
+ * This procedure is invoked to process the
+ * [::tcl::zipfs::tcl_library_init] command, usually called during the
+ * execution of Tcl's interpreter startup. It returns the root that Tcl's
+ * library files are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSTclLibraryObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
+{
+ if (!Tcl_IsSafe(interp)) {
+ Tcl_Obj *pResult = TclZipfs_TclLibrary();
+
+ if (!pResult) {
+ TclNewObj(pResult);
+ }
+ Tcl_SetObjResult(interp, pResult);
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelClose --
+ *
+ * This function is called to close a channel.
+ *
+ * Results:
+ * Always TCL_OK.
+ *
+ * Side effects:
+ * Resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelClose(
+ void *instanceData,
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
+ if (info->iscompr && info->ubuf) {
+ ckfree(info->ubuf);
+ info->ubuf = NULL;
+ }
+ if (info->isEncrypted) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ if (info->isWriting) {
+ ZipEntry *z = info->zipEntryPtr;
+ unsigned char *newdata = (unsigned char *)
+ attemptckrealloc(info->ubuf, info->numRead);
+
+ if (newdata) {
+ if (z->data) {
+ ckfree(z->data);
+ }
+ z->data = newdata;
+ z->numBytes = z->numCompressedBytes = info->numBytes;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->timestamp = time(NULL);
+ z->isDirectory = 0;
+ z->isEncrypted = 0;
+ z->offset = 0;
+ z->crc32 = 0;
+ } else {
+ ckfree(info->ubuf);
+ }
+ }
+ WriteLock();
+ info->zipFilePtr->numOpen--;
+ Unlock();
+ ckfree(info);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelRead --
+ *
+ * This function is called to read data from channel.
+ *
+ * Results:
+ * Number of bytes read or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is read and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelRead(
+ void *instanceData,
+ char *buf,
+ int toRead,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long nextpos;
+
+ if (info->isDirectory < 0) {
+ /*
+ * Special case: when executable combined with ZIP archive file read
+ * data in front of ZIP, i.e. the executable itself.
+ */
+
+ nextpos = info->numRead + toRead;
+ if (nextpos > info->zipFilePtr->baseOffset) {
+ toRead = info->zipFilePtr->baseOffset - info->numRead;
+ nextpos = info->zipFilePtr->baseOffset;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ memcpy(buf, info->zipFilePtr->data, toRead);
+ info->numRead = nextpos;
+ *errloc = 0;
+ return toRead;
+ }
+ if (info->isDirectory) {
+ *errloc = EISDIR;
+ return -1;
+ }
+ nextpos = info->numRead + toRead;
+ if (nextpos > info->numBytes) {
+ toRead = info->numBytes - info->numRead;
+ nextpos = info->numBytes;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ if (info->isEncrypted) {
+ int i;
+
+ for (i = 0; i < toRead; i++) {
+ int ch = info->ubuf[i + info->numRead];
+
+ buf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(buf, info->ubuf + info->numRead, toRead);
+ }
+ info->numRead = nextpos;
+ *errloc = 0;
+ return toRead;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWrite --
+ *
+ * This function is called to write data into channel.
+ *
+ * Results:
+ * Number of bytes written or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is written and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelWrite(
+ void *instanceData,
+ const char *buf,
+ int toWrite,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long nextpos;
+
+ if (!info->isWriting) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ nextpos = info->numRead + toWrite;
+ if (nextpos > info->maxWrite) {
+ toWrite = info->maxWrite - info->numRead;
+ nextpos = info->maxWrite;
+ }
+ if (toWrite == 0) {
+ return 0;
+ }
+ memcpy(info->ubuf + info->numRead, buf, toWrite);
+ info->numRead = nextpos;
+ if (info->numRead > info->numBytes) {
+ info->numBytes = info->numRead;
+ }
+ *errloc = 0;
+ return toWrite;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelSeek/ZipChannelWideSeek --
+ *
+ * This function is called to position file pointer of channel.
+ *
+ * Results:
+ * New file position or -1 on error with error number set.
+ *
+ * Side effects:
+ * File pointer is repositioned according to offset and mode.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static long long
+ZipChannelWideSeek(
+ void *instanceData,
+ long long offset,
+ int mode,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ size_t end;
+
+ if (!info->isWriting && (info->isDirectory < 0)) {
+ /*
+ * Special case: when executable combined with ZIP archive file, seek
+ * within front of ZIP, i.e. the executable itself.
+ */
+ end = info->zipFilePtr->baseOffset;
+ } else if (info->isDirectory) {
+ *errloc = EINVAL;
+ return -1;
+ } else {
+ end = info->numBytes;
+ }
+ switch (mode) {
+ case SEEK_CUR:
+ offset += info->numRead;
+ break;
+ case SEEK_END:
+ offset += end;
+ break;
+ case SEEK_SET:
+ break;
+ default:
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (offset < 0) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (info->isWriting) {
+ if ((size_t) offset > info->maxWrite) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if ((size_t) offset > info->numBytes) {
+ info->numBytes = offset;
+ }
+ } else if ((size_t) offset > end) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ info->numRead = (size_t) offset;
+ return info->numRead;
+}
+
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+static int
+ZipChannelSeek(
+ void *instanceData,
+ long offset,
+ int mode,
+ int *errloc)
+{
+ return ZipChannelWideSeek(instanceData, offset, mode, errloc);
+}
+#endif
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWatchChannel --
+ *
+ * This function is called for event notifications on channel. Does
+ * nothing.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipChannelWatchChannel(
+ TCL_UNUSED(ClientData),
+ TCL_UNUSED(int) /*mask*/)
+{
+ return;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelGetFile --
+ *
+ * This function is called to retrieve OS handle for channel.
+ *
+ * Results:
+ * Always TCL_ERROR since there's never an OS handle for a file within a
+ * ZIP archive.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelGetFile(
+ TCL_UNUSED(ClientData),
+ TCL_UNUSED(int) /*direction*/,
+ TCL_UNUSED(ClientData *) /*handlePtr*/)
+{
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelOpen --
+ *
+ * This function opens a Tcl_Channel on a file from a mounted ZIP archive
+ * according to given open mode (already parsed by caller).
+ *
+ * Results:
+ * Tcl_Channel on success, or NULL on error.
+ *
+ * Side effects:
+ * Memory is allocated, the file from the ZIP archive is uncompressed.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipChannelOpen(
+ Tcl_Interp *interp, /* Current interpreter. */
+ char *filename, /* What are we opening. */
+ int wr, /* True if we're opening in write mode. */
+ int trunc) /* True if we're opening in truncate mode. */
+{
+ ZipEntry *z;
+ ZipChannel *info;
+ int flags = 0;
+ char cname[128];
+
+ /*
+ * Is the file there?
+ */
+
+ WriteLock();
+ z = ZipFSLookup(filename);
+ if (!z) {
+ Tcl_SetErrno(ENOENT);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file not found \"%s\": %s", filename,
+ Tcl_PosixError(interp)));
+ }
+ goto error;
+ }
+
+ /*
+ * Do we support opening the file that way?
+ */
+
+ if (wr && z->isDirectory) {
+ Tcl_SetErrno(EISDIR);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unsupported file type: %s",
+ Tcl_PosixError(interp)));
+ }
+ goto error;
+ }
+ if ((z->compressMethod != ZIP_COMPMETH_STORED)
+ && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) {
+ ZIPFS_ERROR(interp, "unsupported compression method");
+ ZIPFS_ERROR_CODE(interp, "COMP_METHOD");
+ goto error;
+ }
+ if (!trunc) {
+ flags |= TCL_READABLE;
+ if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) {
+ ZIPFS_ERROR(interp, "decryption failed");
+ ZIPFS_ERROR_CODE(interp, "DECRYPT");
+ goto error;
+ } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) {
+ ZIPFS_ERROR(interp, "file too large");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto error;
+ }
+ } else {
+ flags = TCL_WRITABLE;
+ }
+
+ info = AllocateZipChannel(interp);
+ if (!info) {
+ goto error;
+ }
+ info->zipFilePtr = z->zipFilePtr;
+ info->zipEntryPtr = z;
+ if (wr) {
+ /*
+ * Set up a writable channel.
+ */
+
+ flags |= TCL_WRITABLE;
+ if (InitWritableChannel(interp, info, z, trunc) == TCL_ERROR) {
+ ckfree(info);
+ goto error;
+ }
+ } else if (z->data) {
+ /*
+ * Set up a readable channel for direct data.
+ */
+
+ flags |= TCL_READABLE;
+ info->numBytes = z->numBytes;
+ info->ubuf = z->data;
+ } else {
+ /*
+ * Set up a readable channel.
+ */
+
+ flags |= TCL_READABLE;
+ if (InitReadableChannel(interp, info, z) == TCL_ERROR) {
+ ckfree(info);
+ goto error;
+ }
+ }
+
+ /*
+ * Wrap the ZipChannel into a Tcl_Channel.
+ */
+
+ sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
+ ZipFS.idCount++);
+ z->zipFilePtr->numOpen++;
+ Unlock();
+ return Tcl_CreateChannel(&ZipChannelType, cname, info, flags);
+
+ error:
+ Unlock();
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitWritableChannel --
+ *
+ * Assistant for ZipChannelOpen() that sets up a writable channel. It's
+ * up to the caller to actually register the channel.
+ *
+ * Returns:
+ * Tcl result code.
+ *
+ * Side effects:
+ * Allocates memory for the implementation of the channel. Writes to the
+ * interpreter's result on error.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+InitWritableChannel(
+ Tcl_Interp *interp, /* Current interpreter, or NULL (when errors
+ * will be silent). */
+ ZipChannel *info, /* The channel to set up. */
+ ZipEntry *z, /* The zipped file that the channel will write
+ * to. */
+ int trunc) /* Whether to truncate the data. */
+{
+ int i, ch;
+ unsigned char *cbuf = NULL;
+
+ /*
+ * Set up a writable channel.
+ */
+
+ info->isWriting = 1;
+ info->maxWrite = ZipFS.wrmax;
+
+ info->ubuf = (unsigned char *) attemptckalloc(info->maxWrite);
+ if (!info->ubuf) {
+ goto memoryError;
+ }
+ memset(info->ubuf, 0, info->maxWrite);
+
+ if (trunc) {
+ /*
+ * Truncate; nothing there.
+ */
+
+ info->numBytes = 0;
+ } else if (z->data) {
+ /*
+ * Already got uncompressed data.
+ */
+
+ unsigned int j = z->numBytes;
+
+ if (j > info->maxWrite) {
+ j = info->maxWrite;
+ }
+ memcpy(info->ubuf, z->data, j);
+ info->numBytes = j;
+ } else {
+ /*
+ * Need to uncompress the existing data.
+ */
+
+ unsigned char *zbuf = z->zipFilePtr->data + z->offset;
+
+ if (z->isEncrypted) {
+ int len = z->zipFilePtr->passBuf[0] & 0xFF;
+ char passBuf[260];
+
+ for (i = 0; i < len; i++) {
+ ch = z->zipFilePtr->passBuf[len - i];
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ }
+ passBuf[i] = '\0';
+ init_keys(passBuf, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ zbuf += i;
+ }
+
+ if (z->compressMethod == ZIP_COMPMETH_DEFLATED) {
+ z_stream stream;
+ int err;
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (z->isEncrypted) {
+ unsigned int j;
+
+ stream.avail_in -= 12;
+ cbuf = (unsigned char *) attemptckalloc(stream.avail_in);
+ if (!cbuf) {
+ goto memoryError;
+ }
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[j];
+ cbuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = cbuf;
+ } else {
+ stream.next_in = zbuf;
+ }
+ stream.next_out = info->ubuf;
+ stream.avail_out = info->maxWrite;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto corruptionError;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+ if ((err == Z_STREAM_END)
+ || ((err == Z_OK) && (stream.avail_in == 0))) {
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ return TCL_OK;
+ }
+ goto corruptionError;
+ } else if (z->isEncrypted) {
+ /*
+ * Need to decrypt some otherwise-simple stored data.
+ */
+
+ for (i = 0; i < z->numBytes - 12; i++) {
+ ch = zbuf[i];
+ info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ /*
+ * Simple stored data. Copy into our working buffer.
+ */
+
+ memcpy(info->ubuf, zbuf, z->numBytes);
+ }
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ return TCL_OK;
+
+ memoryError:
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_MEM_ERROR(interp);
+ return TCL_ERROR;
+
+ corruptionError:
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitReadableChannel --
+ *
+ * Assistant for ZipChannelOpen() that sets up a readable channel. It's
+ * up to the caller to actually register the channel.
+ *
+ * Returns:
+ * Tcl result code.
+ *
+ * Side effects:
+ * Allocates memory for the implementation of the channel. Writes to the
+ * interpreter's result on error.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+InitReadableChannel(
+ Tcl_Interp *interp, /* Current interpreter, or NULL (when errors
+ * will be silent). */
+ ZipChannel *info, /* The channel to set up. */
+ ZipEntry *z) /* The zipped file that the channel will read
+ * from. */
+{
+ unsigned char *ubuf = NULL;
+ int i, ch;
+
+ info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
+ info->ubuf = z->zipFilePtr->data + z->offset;
+ info->isDirectory = z->isDirectory;
+ info->isEncrypted = z->isEncrypted;
+ info->numBytes = z->numBytes;
+
+ if (info->isEncrypted) {
+ int len = z->zipFilePtr->passBuf[0] & 0xFF;
+ char passBuf[260];
+
+ for (i = 0; i < len; i++) {
+ ch = z->zipFilePtr->passBuf[len - i];
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ }
+ passBuf[i] = '\0';
+ init_keys(passBuf, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubuf += i;
+ }
+
+ if (info->iscompr) {
+ z_stream stream;
+ int err;
+ unsigned int j;
+
+ /*
+ * Data to decode is compressed, and possibly encrpyted too.
+ */
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (info->isEncrypted) {
+ stream.avail_in -= 12;
+ ubuf = (unsigned char *) attemptckalloc(stream.avail_in);
+ if (!ubuf) {
+ info->ubuf = NULL;
+ goto memoryError;
+ }
+
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = ubuf;
+ } else {
+ stream.next_in = info->ubuf;
+ }
+ stream.next_out = info->ubuf = (unsigned char *)
+ attemptckalloc(info->numBytes);
+ if (!info->ubuf) {
+ goto memoryError;
+ }
+ stream.avail_out = info->numBytes;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto corruptionError;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+
+ /*
+ * Decompression was successful if we're either in the END state, or
+ * in the OK state with no buffered bytes.
+ */
+
+ if ((err != Z_STREAM_END)
+ && ((err != Z_OK) || (stream.avail_in != 0))) {
+ goto corruptionError;
+ }
+
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ return TCL_OK;
+ } else if (info->isEncrypted) {
+ unsigned int j, len;
+
+ /*
+ * Decode encrypted but uncompressed file, since we support Tcl_Seek()
+ * on it, and it can be randomly accessed later.
+ */
+
+ len = z->numCompressedBytes - 12;
+ ubuf = (unsigned char *) attemptckalloc(len);
+ if (ubuf == NULL) {
+ goto memoryError;
+ }
+ for (j = 0; j < len; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubuf = ubuf;
+ info->isEncrypted = 0;
+ }
+ return TCL_OK;
+
+ corruptionError:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+ return TCL_ERROR;
+
+ memoryError:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ ZIPFS_MEM_ERROR(interp);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryStat --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryStat(
+ char *path,
+ Tcl_StatBuf *buf)
+{
+ ZipEntry *z;
+ int ret = -1;
+
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (z) {
+ memset(buf, 0, sizeof(Tcl_StatBuf));
+ if (z->isDirectory) {
+ buf->st_mode = S_IFDIR | 0555;
+ } else {
+ buf->st_mode = S_IFREG | 0555;
+ }
+ buf->st_size = z->numBytes;
+ buf->st_mtime = z->timestamp;
+ buf->st_ctime = z->timestamp;
+ buf->st_atime = z->timestamp;
+ ret = 0;
+ }
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryAccess --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryAccess(
+ char *path,
+ int mode)
+{
+ ZipEntry *z;
+
+ if (mode & 3) {
+ return -1;
+ }
+ ReadLock();
+ z = ZipFSLookup(path);
+ Unlock();
+ return (z ? 0 : -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenFileChannelProc --
+ *
+ * Open a channel to a file in a mounted ZIP archive. Delegates to
+ * ZipChannelOpen().
+ *
+ * Results:
+ * Tcl_Channel on success, or NULL on error.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipFSOpenFileChannelProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathPtr,
+ int mode,
+ TCL_UNUSED(int) /* permissions */)
+{
+ int trunc = (mode & O_TRUNC) != 0;
+ int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return NULL;
+ }
+
+ /*
+ * Check for unsupported modes.
+ */
+
+ if ((mode & O_APPEND) || ((ZipFS.wrmax <= 0) && wr)) {
+ Tcl_SetErrno(EACCES);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write access not supported: %s",
+ Tcl_PosixError(interp)));
+ }
+ return NULL;
+ }
+
+ return ZipChannelOpen(interp, Tcl_GetString(pathPtr), wr, trunc);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSStatProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSStatProc(
+ Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf)
+{
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryStat(Tcl_GetString(pathPtr), buf);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSAccessProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSAccessProc(
+ Tcl_Obj *pathPtr,
+ int mode)
+{
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryAccess(Tcl_GetString(pathPtr), mode);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemSeparatorProc --
+ *
+ * This function returns the separator to be used for a given path. The
+ * object returned should have a refCount of zero
+ *
+ * Results:
+ * A Tcl object, with a refCount of zero. If the caller needs to retain a
+ * reference to the object, it should call Tcl_IncrRefCount, and should
+ * otherwise free the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemSeparatorProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
+{
+ return Tcl_NewStringObj("/", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * AppendWithPrefix --
+ *
+ * Worker for ZipFSMatchInDirectoryProc() that is a wrapper around
+ * Tcl_ListObjAppendElement() which knows about handling prefixes.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline void
+AppendWithPrefix(
+ Tcl_Obj *result, /* Where to append a list element to. */
+ Tcl_DString *prefix, /* The prefix to add to the element, or NULL
+ * for don't do that. */
+ const char *name, /* The name to append. */
+ int nameLen) /* The length of the name. May be -1 for
+ * append-up-to-NUL-byte. */
+{
+ if (prefix) {
+ int prefixLength = Tcl_DStringLength(prefix);
+
+ Tcl_DStringAppend(prefix, name, nameLen);
+ Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
+ Tcl_DStringValue(prefix), Tcl_DStringLength(prefix)));
+ Tcl_DStringSetLength(prefix, prefixLength);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(name, nameLen));
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMatchInDirectoryProc --
+ *
+ * This routine is used by the globbing code to search a directory for
+ * all files which match a given pattern.
+ *
+ * Results:
+ * The return value is a standard Tcl result indicating whether an error
+ * occurred in globbing. Errors are left in interp, good results are
+ * lappend'ed to resultPtr (which must be a valid object).
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMatchInDirectoryProc(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *result, /* Where to append matched items to. */
+ Tcl_Obj *pathPtr, /* Where we are looking. */
+ const char *pattern, /* What names we are looking for. */
+ Tcl_GlobTypeData *types) /* What types we are looking for. */
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len;
+ char *pat, *prefix, *path;
+ Tcl_DString dsPref, *prefixBuf = NULL;
+
+ if (!normPathPtr) {
+ return -1;
+ }
+ if (types) {
+ dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
+ mounts = (types->type == TCL_GLOB_TYPE_MOUNT);
+ }
+
+ /*
+ * The prefix that gets prepended to results.
+ */
+
+ prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
+
+ /*
+ * The (normalized) path we're searching.
+ */
+
+ path = Tcl_GetStringFromObj(normPathPtr, &len);
+
+ Tcl_DStringInit(&dsPref);
+ if (strcmp(prefix, path) == 0) {
+ prefixBuf = NULL;
+ } else {
+ /*
+ * We need to strip the normalized prefix of the filenames and replace
+ * it with the official prefix that we were expecting to get.
+ */
+
+ strip = len + 1;
+ Tcl_DStringAppend(&dsPref, prefix, prefixLen);
+ Tcl_DStringAppend(&dsPref, "/", 1);
+ prefix = Tcl_DStringValue(&dsPref);
+ prefixBuf = &dsPref;
+ }
+
+ ReadLock();
+
+ /*
+ * Are we globbing the mount points?
+ */
+
+ if (mounts) {
+ ZipFSMatchMountPoints(result, normPathPtr, pattern, prefixBuf);
+ goto end;
+ }
+
+ /*
+ * Can we skip the complexity of actual globbing? Without a pattern, yes;
+ * it's a directory existence test.
+ */
+
+ if (!pattern || (pattern[0] == '\0')) {
+ ZipEntry *z = ZipFSLookup(path);
+
+ if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
+ || (dirOnly && z->isDirectory))) {
+ AppendWithPrefix(result, prefixBuf, z->name, -1);
+ }
+ goto end;
+ }
+
+ /*
+ * We've got to work for our supper and do the actual globbing. And all
+ * we've got really is an undifferentiated pile of all the filenames we've
+ * got from all our ZIP mounts.
+ */
+
+ l = strlen(pattern);
+ pat = (char *) ckalloc(len + l + 2);
+ memcpy(pat, path, len);
+ while ((len > 1) && (pat[len - 1] == '/')) {
+ --len;
+ }
+ if ((len > 1) || (pat[0] != '/')) {
+ pat[len] = '/';
+ ++len;
+ }
+ memcpy(pat + len, pattern, l + 1);
+ scnt = CountSlashes(pat);
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
+ || (!dirOnly && z->isDirectory))) {
+ continue;
+ }
+ if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
+ AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
+ }
+ }
+ ckfree(pat);
+
+ end:
+ Unlock();
+ Tcl_DStringFree(&dsPref);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMatchMountPoints --
+ *
+ * This routine is a worker for ZipFSMatchInDirectoryProc, used by the
+ * globbing code to search for all mount points files which match a given
+ * pattern.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adds the matching mounts to the list in result, uses prefix as working
+ * space if it is non-NULL.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipFSMatchMountPoints(
+ Tcl_Obj *result, /* The list of matches being built. */
+ Tcl_Obj *normPathPtr, /* Where we're looking from. */
+ const char *pattern, /* What we're looking for. NULL for a full
+ * list. */
+ Tcl_DString *prefix) /* Workspace filled with a prefix for all the
+ * filenames, or NULL if no prefix is to be
+ * used. */
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int l, normLength;
+ const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength);
+ size_t len = (size_t) normLength;
+
+ if (len < 1) {
+ /*
+ * Shouldn't happen. But "shouldn't"...
+ */
+
+ return;
+ }
+ l = CountSlashes(path);
+ if (path[len - 1] == '/') {
+ len--;
+ } else {
+ l++;
+ }
+ if (!pattern || (pattern[0] == '\0')) {
+ pattern = "*";
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ /*
+ * Enumerate the contents of the ZIP; it's mounted on the root.
+ */
+
+ for (z = zf->topEnts; z; z = z->tnext) {
+ size_t lenz = strlen(z->name);
+
+ if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0)
+ && (z->name[len] == '/')
+ && (CountSlashes(z->name) == l)
+ && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) {
+ AppendWithPrefix(result, prefix, z->name, lenz);
+ }
+ }
+ } else if ((zf->mountPointLen > len + 1)
+ && (strncmp(zf->mountPoint, path, len) == 0)
+ && (zf->mountPoint[len] == '/')
+ && (CountSlashes(zf->mountPoint) == l)
+ && Tcl_StringCaseMatch(zf->mountPoint + len + 1,
+ pattern, 0)) {
+ /*
+ * Standard mount; append if it matches.
+ */
+
+ AppendWithPrefix(result, prefix, zf->mountPoint, zf->mountPointLen);
+ }
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSPathInFilesystemProc --
+ *
+ * This function determines if the given path object is in the ZIP
+ * filesystem.
+ *
+ * Results:
+ * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSPathInFilesystemProc(
+ Tcl_Obj *pathPtr,
+ TCL_UNUSED(ClientData *))
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int ret = -1, len;
+ char *path;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = Tcl_GetStringFromObj(pathPtr, &len);
+ if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) {
+ return -1;
+ }
+
+ ReadLock();
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
+ if (hPtr) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ for (z = zf->topEnts; z != NULL; z = z->tnext) {
+ size_t lenz = strlen(z->name);
+
+ if (((size_t) len >= lenz) &&
+ (strncmp(path, z->name, lenz) == 0)) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+ }
+ } else if (((size_t) len >= zf->mountPointLen) &&
+ (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) {
+ ret = TCL_OK;
+ break;
+ }
+ }
+
+ endloop:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListVolumesProc --
+ *
+ * Lists the currently mounted ZIP filesystem volumes.
+ *
+ * Results:
+ * The list of volumes.
+ *
+ * Side effects:
+ * None
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSListVolumesProc(void)
+{
+ return Tcl_NewStringObj(ZIPFS_VOLUME, -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrStringsProc --
+ *
+ * This function implements the ZIP filesystem dependent 'file
+ * attributes' subcommand, for listing the set of possible attribute
+ * strings.
+ *
+ * Results:
+ * An array of strings
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+enum ZipFileAttrs {
+ ZIP_ATTR_UNCOMPSIZE,
+ ZIP_ATTR_COMPSIZE,
+ ZIP_ATTR_OFFSET,
+ ZIP_ATTR_MOUNT,
+ ZIP_ATTR_ARCHIVE,
+ ZIP_ATTR_PERMISSIONS,
+ ZIP_ATTR_CRC
+};
+
+static const char *const *
+ZipFSFileAttrStringsProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
+ TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/)
+{
+ /*
+ * Must match up with ZipFileAttrs enum above.
+ */
+
+ static const char *const attrs[] = {
+ "-uncompsize",
+ "-compsize",
+ "-offset",
+ "-mount",
+ "-archive",
+ "-permissions",
+ "-crc",
+ NULL,
+ };
+
+ return attrs;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsGetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'get' operations.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
+ * was returned) is likely to have a refCount of zero. Either way we must
+ * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
+ * refCount to ensure it is properly freed.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsGetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int index,
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
+{
+ int len, ret = TCL_OK;
+ char *path;
+ ZipEntry *z;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = Tcl_GetStringFromObj(pathPtr, &len);
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (!z) {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_POSIX_ERROR(interp, "file not found");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case ZIP_ATTR_UNCOMPSIZE:
+ TclNewIntObj(*objPtrRef, z->numBytes);
+ break;
+ case ZIP_ATTR_COMPSIZE:
+ TclNewIntObj(*objPtrRef, z->numCompressedBytes);
+ break;
+ case ZIP_ATTR_OFFSET:
+ TclNewIntObj(*objPtrRef, z->offset);
+ break;
+ case ZIP_ATTR_MOUNT:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
+ z->zipFilePtr->mountPointLen);
+ break;
+ case ZIP_ATTR_ARCHIVE:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
+ break;
+ case ZIP_ATTR_PERMISSIONS:
+ *objPtrRef = Tcl_NewStringObj("0o555", -1);
+ break;
+ case ZIP_ATTR_CRC:
+ TclNewIntObj(*objPtrRef, z->crc32);
+ break;
+ default:
+ ZIPFS_ERROR(interp, "unknown attribute");
+ ZIPFS_ERROR_CODE(interp, "FILE_ATTR");
+ ret = TCL_ERROR;
+ }
+
+ done:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsSetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'set' operations.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsSetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*index*/,
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
+ TCL_UNUSED(Tcl_Obj *) /*objPtr*/)
+{
+ ZIPFS_ERROR(interp, "unsupported operation");
+ ZIPFS_ERROR_CODE(interp, "UNSUPPORTED_OP");
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemPathTypeProc --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemPathTypeProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
+{
+ return Tcl_NewStringObj("zip", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLoadFile --
+ *
+ * This functions deals with loading native object code. If the given
+ * path object refers to a file within the ZIP filesystem, an approriate
+ * error code is returned to delegate loading to the caller (by copying
+ * the file to temp store and loading from there). As fallback when the
+ * file refers to the ZIP file system but is not present, it is looked up
+ * relative to the executable and loaded from there when available.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with error message left.
+ *
+ * Side effects:
+ * Loads native code into the process address space.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSLoadFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *path,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr,
+ int flags)
+{
+ Tcl_FSLoadFileProc2 *loadFileProc;
+#ifdef ANDROID
+ /*
+ * Force loadFileProc to native implementation since the package manager
+ * already extracted the shared libraries from the APK at install time.
+ */
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ }
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return TCL_ERROR;
+#else /* !ANDROID */
+ Tcl_Obj *altPath = NULL;
+ int ret = TCL_ERROR;
+ Tcl_Obj *objs[2] = { NULL, NULL };
+
+ if (Tcl_FSAccess(path, R_OK) == 0) {
+ /*
+ * EXDEV should trigger loading by copying to temp store.
+ */
+
+ Tcl_SetErrno(EXDEV);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return ret;
+ }
+
+ objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME);
+ if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) {
+ const char *execName = Tcl_GetNameOfExecutable();
+
+ /*
+ * Shared object is not in ZIP but its path prefix is, thus try to
+ * load from directory where the executable came from.
+ */
+
+ TclDecrRefCount(objs[1]);
+ objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL);
+
+ /*
+ * Get directory name of executable manually to deal with cases where
+ * [file dirname [info nameofexecutable]] is equal to [info
+ * nameofexecutable] due to VFS effects.
+ */
+
+ if (execName) {
+ const char *p = strrchr(execName, '/');
+
+ if (p && p > execName + 1) {
+ --p;
+ objs[0] = Tcl_NewStringObj(execName, p - execName);
+ }
+ }
+ if (!objs[0]) {
+ objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
+ TCL_PATH_DIRNAME);
+ }
+ if (objs[0]) {
+ altPath = TclJoinPath(2, objs, 0);
+ if (altPath) {
+ Tcl_IncrRefCount(altPath);
+ if (Tcl_FSAccess(altPath, R_OK) == 0) {
+ path = altPath;
+ }
+ }
+ }
+ }
+ if (objs[0]) {
+ Tcl_DecrRefCount(objs[0]);
+ }
+ if (objs[1]) {
+ Tcl_DecrRefCount(objs[1]);
+ }
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) (void *)
+ tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ } else {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ }
+ if (altPath) {
+ Tcl_DecrRefCount(altPath);
+ }
+ return ret;
+#endif /* ANDROID */
+}
+
+#endif /* HAVE_ZLIB */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Init --
+ *
+ * Perform per interpreter initialization of this module.
+ *
+ * Results:
+ * The return value is a standard Tcl result.
+ *
+ * Side effects:
+ * Initializes this module if not already initialized, and adds module
+ * related commands to the given interpreter.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Init(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+#ifdef HAVE_ZLIB
+ static const EnsembleImplMap initMap[] = {
+ {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
+ {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1},
+ /* The 4 entries above are not available in safe interpreters */
+ {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1},
+ {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1},
+ {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1},
+ {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1},
+ {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0},
+ {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0},
+ {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0},
+ {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0},
+ {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ static const char findproc[] =
+ "namespace eval ::tcl::zipfs {}\n"
+ "proc ::tcl::zipfs::Find dir {\n"
+ " set result {}\n"
+ " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n"
+ " return $result\n"
+ " }\n"
+ " foreach file $list {\n"
+ " if {[file tail $file] in {. ..}} {\n"
+ " continue\n"
+ " }\n"
+ " lappend result $file {*}[Find $file]\n"
+ " }\n"
+ " return $result\n"
+ "}\n"
+ "proc ::tcl::zipfs::find {directoryName} {\n"
+ " return [lsort [Find $directoryName]]\n"
+ "}\n";
+
+ /*
+ * One-time initialization.
+ */
+
+ WriteLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+ Unlock();
+
+ if (interp) {
+ Tcl_Command ensemble;
+ Tcl_Obj *mapObj;
+
+ Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL);
+ if (!Tcl_IsSafe(interp)) {
+ Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,
+ TCL_LINK_INT);
+ Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding",
+ (char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING);
+ }
+ ensemble = TclMakeEnsemble(interp, "zipfs",
+ Tcl_IsSafe(interp) ? (initMap + 4) : initMap);
+
+ /*
+ * Add the [zipfs find] subcommand.
+ */
+
+ Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
+ Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
+ Tcl_NewStringObj("::tcl::zipfs::find", -1));
+ Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
+ ZipFSTclLibraryObjCmd, NULL, NULL);
+ Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
+ }
+ return TCL_OK;
+#else /* !HAVE_ZLIB */
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+#endif /* HAVE_ZLIB */
+}
+
+#ifdef HAVE_ZLIB
+
+#if !defined(STATIC_BUILD)
+static int
+ZipfsAppHookFindTclInit(
+ const char *archive)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+
+ if (zipfs_literal_tcl_library) {
+ return TCL_ERROR;
+ }
+ if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) {
+ /* Either the file doesn't exist or it is not a zip archive */
+ return TCL_ERROR;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT;
+ return TCL_OK;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+#endif
+
+static void
+ZipfsExitHandler(
+ TCL_UNUSED(ClientData)
+)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ if (ZipFS.initialized != -1) {
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ } else {
+ /* ZipFS.fallbackEntryEncoding was already freed by
+ * ZipfsMountExitHandler
+ */
+ }
+ }
+}
+
+static void
+ZipfsFinalize(void) {
+ Tcl_FSUnregister(&zipfsFilesystem);
+ Tcl_DeleteHashTable(&ZipFS.fileHash);
+ ckfree(ZipFS.fallbackEntryEncoding);
+ ZipFS.initialized = -1;
+}
+
+static void
+ZipfsMountExitHandler(
+ ClientData clientData)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ ZipFile *zf = (ZipFile *) clientData;
+
+ if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+ Tcl_Panic("tried to unmount busy filesystem");
+ }
+
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ }
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_AppHook --
+ *
+ * Performs the argument munging for the shell
+ *
+ *-------------------------------------------------------------------------
+ */
+
+const char *
+TclZipfs_AppHook(
+#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
+ int *argcPtr, /* Pointer to argc */
+#else
+ TCL_UNUSED(int *), /*argcPtr*/
+#endif
+#ifdef _WIN32
+ TCL_UNUSED(WCHAR ***)) /* argvPtr */
+#else /* !_WIN32 */
+ char ***argvPtr) /* Pointer to argv */
+#endif /* _WIN32 */
+{
+ const char *archive;
+ const char *version = Tcl_InitSubsystems();
+
+#ifdef _WIN32
+ Tcl_FindExecutable(NULL);
+#else
+ Tcl_FindExecutable((*argvPtr)[0]);
+#endif
+ archive = Tcl_GetNameOfExecutable();
+ TclZipfs_Init(NULL);
+
+ /*
+ * Look for init.tcl in one of the locations mounted later in this
+ * function.
+ */
+
+ if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+
+ /*
+ * Set Tcl Encodings
+ */
+
+ if (!zipfs_literal_tcl_library) {
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return version;
+ }
+ }
+#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
+ } else if (*argcPtr > 1) {
+ /*
+ * If the first argument is "install", run the supplied installer
+ * script.
+ */
+
+#ifdef _WIN32
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ archive = Tcl_WCharToUtfDString((*argvPtr)[1], -1, &ds);
+#else /* !_WIN32 */
+ archive = (*argvPtr)[1];
+#endif /* _WIN32 */
+ if (strcmp(archive, "install") == 0) {
+ Tcl_Obj *vfsInitScript;
+
+ /*
+ * Run this now to ensure the file is present by the time Tcl_Main
+ * wants it.
+ */
+
+ TclZipfs_TclLibrary();
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ }
+ return version;
+ } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+ /* Set Tcl Encodings */
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return version;
+ }
+ }
+#ifdef _WIN32
+ Tcl_DStringFree(&ds);
+#endif /* _WIN32 */
+#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
+ }
+ return version;
+}
+
+#else /* !HAVE_ZLIB */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
+ *
+ * Dummy version when no ZLIB support available.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(const char *), /* Mount point path. */
+ TCL_UNUSED(const char *), /* Path to ZIP file to mount. */
+ TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ TCL_UNUSED(const char *), /* Mount point path. */
+ TCL_UNUSED(unsigned char *),
+ TCL_UNUSED(size_t),
+ TCL_UNUSED(int))
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(const char *)) /* Mount point path. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+const char *
+TclZipfs_AppHook(
+ TCL_UNUSED(int *), /*argcPtr*/
+#ifdef _WIN32
+ TCL_UNUSED(WCHAR ***)) /* argvPtr */
+#else /* !_WIN32 */
+ TCL_UNUSED(char ***)) /* Pointer to argv */
+#endif /* _WIN32 */
+{
+ return NULL;
+}
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ return NULL;
+}
+
+#endif /* !HAVE_ZLIB */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 63a25fa..61dc0ee 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -3,9 +3,9 @@
*
* 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-2012 Donal K. Fellows
+ * Copyright © 2004-2005 Pascal Scheffers <pascal@scheffers.net>
+ * Copyright © 2005 Unitas Software B.V.
+ * Copyright © 2008-2012 Donal K. Fellows
*
* Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the
* public domain March 2003.
@@ -110,14 +110,14 @@ typedef struct {
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
- int readAheadLimit; /* The maximum number of bytes to read from
+ unsigned int readAheadLimit;/* The maximum number of bytes to read from
* the underlying stream in one go. */
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;
+ size_t inAllocated, outAllocated;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
@@ -163,7 +163,7 @@ typedef struct {
static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
-static Tcl_DriverCloseProc ZlibTransformClose;
+static Tcl_DriverClose2Proc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
static Tcl_DriverHandlerProc ZlibTransformEventHandler;
@@ -197,7 +197,7 @@ static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
-static void ZlibTransformTimerRun(ClientData clientData);
+static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
@@ -206,7 +206,7 @@ static void ZlibTransformTimerRun(ClientData clientData);
static const Tcl_ChannelType zlibChannelType = {
"zlib",
TCL_CHANNEL_VERSION_5,
- ZlibTransformClose,
+ TCL_CLOSE2PROC,
ZlibTransformInput,
ZlibTransformOutput,
NULL, /* seekProc */
@@ -214,7 +214,7 @@ static const Tcl_ChannelType zlibChannelType = {
ZlibTransformGetOption,
ZlibTransformWatch,
ZlibTransformGetHandle,
- NULL, /* close2Proc */
+ ZlibTransformClose, /* close2Proc */
ZlibTransformBlockMode,
NULL, /* flushProc */
ZlibTransformEventHandler,
@@ -354,7 +354,7 @@ ConvertErrorToList(
return Tcl_NewListObj(4, objv);
case Z_NEED_DICT:
TclNewLiteralStringObj(objv[2], "NEED_DICT");
- objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler);
+ TclNewIntObj(objv[3], (Tcl_WideInt)adler);
return Tcl_NewListObj(4, objv);
/*
@@ -423,6 +423,7 @@ GenerateHeader(
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
+ Tcl_WideInt wideValue = 0;
const char *valueStr;
Tcl_Encoding latin1enc;
static const char *const types[] = {
@@ -441,7 +442,7 @@ GenerateHeader(
if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
@@ -462,7 +463,7 @@ GenerateHeader(
if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
headerPtr->nativeFilenameBuf[len] = '\0';
@@ -486,10 +487,11 @@ GenerateHeader(
if (GetValue(interp, dictObj, "time", &value) != TCL_OK) {
goto error;
- } else if (value != NULL && Tcl_GetLongFromObj(interp, value,
- (long *) &headerPtr->header.time) != TCL_OK) {
+ } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value,
+ &wideValue) != TCL_OK) {
goto error;
}
+ headerPtr->header.time = wideValue;
if (GetValue(interp, dictObj, "type", &value) != TCL_OK) {
goto error;
@@ -546,7 +548,7 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
&tmp);
- SetValue(dictObj, "comment", TclDStringToObj(&tmp));
+ SetValue(dictObj, "comment", Tcl_DStringToObj(&tmp));
}
SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
if (headerPtr->name != Z_NULL) {
@@ -563,13 +565,13 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
&tmp);
- SetValue(dictObj, "filename", TclDStringToObj(&tmp));
+ SetValue(dictObj, "filename", Tcl_DStringToObj(&tmp));
}
if (headerPtr->os != 255) {
- SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os));
+ SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os));
}
if (headerPtr->time != 0 /* magic - no time */) {
- SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time));
+ SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time));
}
if (headerPtr->text != Z_UNKNOWN) {
SetValue(dictObj, "type",
@@ -883,7 +885,7 @@ Tcl_ZlibStreamInit(
static void
ZlibStreamCmdDelete(
- ClientData cd)
+ void *cd)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
@@ -1151,6 +1153,11 @@ Tcl_ZlibStreamSetCompressionDictionary(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL,
+ compressionDictionaryObj, (int *)NULL))) {
+ /* Missing or invalid compression dictionary */
+ compressionDictionaryObj = NULL;
+ }
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
@@ -1190,6 +1197,7 @@ Tcl_ZlibStreamPut(
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize, toStore;
+ unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
@@ -1200,8 +1208,13 @@ Tcl_ZlibStreamPut(
return TCL_ERROR;
}
+ bytes = TclGetBytesFromObj(zshPtr->interp, data, &size);
+ if (bytes == NULL) {
+ return TCL_ERROR;
+ }
+
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
- zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size);
+ zshPtr->stream.next_in = bytes;
zshPtr->stream.avail_in = size;
/*
@@ -1325,7 +1338,9 @@ Tcl_ZlibStreamGet(
return TCL_OK;
}
- (void) Tcl_GetByteArrayFromObj(data, &existing);
+ if (NULL == TclGetBytesFromObj(zshPtr->interp, data, &existing)) {
+ return TCL_ERROR;
+ }
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
@@ -1355,7 +1370,7 @@ Tcl_ZlibStreamGet(
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = NULL;
}
- TclListObjLength(NULL, zshPtr->inData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->inData, &listLen);
if (listLen > 0) {
/*
* There is more input available, get it from the list and
@@ -1404,7 +1419,7 @@ Tcl_ZlibStreamGet(
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
- TclListObjLength(NULL, zshPtr->inData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
@@ -1484,7 +1499,7 @@ Tcl_ZlibStreamGet(
inflateEnd(&zshPtr->stream);
}
} else {
- TclListObjLength(NULL, zshPtr->outData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->outData, &listLen);
if (count == -1) {
count = 0;
for (i=0; i<listLen; i++) {
@@ -1506,7 +1521,7 @@ Tcl_ZlibStreamGet(
dataPtr += existing;
while ((count > dataPos) &&
- (TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK)
+ (TclListObjLengthM(NULL, zshPtr->outData, &listLen) == TCL_OK)
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
@@ -1516,7 +1531,7 @@ Tcl_ZlibStreamGet(
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (itemLen-zshPtr->outPos >= count-dataPos) {
- unsigned len = count - dataPos;
+ size_t len = count - dataPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
zshPtr->outPos += len;
@@ -1525,7 +1540,7 @@ Tcl_ZlibStreamGet(
zshPtr->outPos = 0;
}
} else {
- unsigned len = itemLen - zshPtr->outPos;
+ size_t len = itemLen - zshPtr->outPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
dataPos += len;
@@ -1573,6 +1588,16 @@ Tcl_ZlibDeflate(
}
/*
+ * Obtain the pointer to the byte array, we'll pass this pointer straight
+ * to the deflate command.
+ */
+
+ inData = TclGetBytesFromObj(interp, data, &inLen);
+ if (inData == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
@@ -1616,12 +1641,6 @@ Tcl_ZlibDeflate(
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;
@@ -1722,6 +1741,11 @@ Tcl_ZlibInflate(
return TCL_ERROR;
}
+ inData = TclGetBytesFromObj(interp, data, &inLen);
+ if (inData == NULL) {
+ return TCL_ERROR;
+ }
+
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
@@ -1759,7 +1783,6 @@ Tcl_ZlibInflate(
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.
@@ -1859,7 +1882,7 @@ Tcl_ZlibInflate(
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
SetValue(gzipHeaderDictObj, "size",
- Tcl_NewLongObj(stream.total_out));
+ Tcl_NewWideIntObj(stream.total_out));
ckfree(nameBuf);
ckfree(commentBuf);
}
@@ -1919,7 +1942,7 @@ Tcl_ZlibAdler32(
static int
ZlibCmd(
- ClientData notUsed,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1955,6 +1978,10 @@ ZlibCmd(
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
+ data = TclGetBytesFromObj(interp, objv[2], &dlen);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
@@ -1962,7 +1989,6 @@ ZlibCmd(
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
- data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibAdler32(start, data, dlen)));
return TCL_OK;
@@ -1972,6 +1998,10 @@ ZlibCmd(
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
+ data = TclGetBytesFromObj(interp, objv[2], &dlen);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
@@ -1979,7 +2009,6 @@ ZlibCmd(
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
- data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibCRC32(start, data, dlen)));
return TCL_OK;
@@ -2312,6 +2341,12 @@ ZlibStreamSubcmd(
return TCL_ERROR;
}
+ if (compDictObj) {
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
+ return TCL_ERROR;
+ }
+ }
+
/*
* Construct the stream now we know its configuration.
*/
@@ -2363,7 +2398,7 @@ ZlibPushSubcmd(
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
- enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
+ enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = DEFAULT_BUFFER_SIZE, dummy;
@@ -2445,7 +2480,7 @@ ZlibPushSubcmd(
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
- switch ((enum pushOptions) option) {
+ switch ((enum pushOptionsEnum) option) {
case poHeader:
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
@@ -2489,6 +2524,10 @@ ZlibPushSubcmd(
}
}
+ if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, NULL))) {
+ return TCL_ERROR;
+ }
+
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
@@ -2515,7 +2554,7 @@ ZlibPushSubcmd(
static int
ZlibStreamCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2618,7 +2657,7 @@ ZlibStreamCmd(
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream)));
return TCL_OK;
case zs_checksum: /* $strm checksum */
if (objc != 2) {
@@ -2641,7 +2680,7 @@ ZlibStreamCmd(
static int
ZlibStreamAddCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2734,7 +2773,10 @@ ZlibStreamAddCmd(
if (compDictObj != NULL) {
int len;
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
+ return TCL_ERROR;
+ }
+
if (len == 0) {
compDictObj = NULL;
}
@@ -2765,7 +2807,7 @@ ZlibStreamAddCmd(
static int
ZlibStreamPutCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2838,7 +2880,9 @@ ZlibStreamPutCmd(
if (compDictObj != NULL) {
int len;
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
+ return TCL_ERROR;
+ }
if (len == 0) {
compDictObj = NULL;
}
@@ -2854,7 +2898,7 @@ ZlibStreamPutCmd(
static int
ZlibStreamHeaderCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2893,12 +2937,17 @@ ZlibStreamHeaderCmd(
static int
ZlibTransformClose(
- ClientData instanceData,
- Tcl_Interp *interp)
+ void *instanceData,
+ Tcl_Interp *interp,
+ int flags)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
int e, written, result = TCL_OK;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
/*
* Delete the support timer.
*/
@@ -2932,7 +2981,7 @@ ZlibTransformClose(
result = TCL_ERROR;
break;
}
- if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) {
+ if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) {
/* TODO: is this the right way to do errors on close?
* Note: when close is called from FinalizeIOSubsystem then
* interp may be NULL */
@@ -2992,7 +3041,7 @@ ZlibTransformClose(
static int
ZlibTransformInput(
- ClientData instanceData,
+ void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -3010,7 +3059,7 @@ ZlibTransformInput(
gotBytes = 0;
readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */
while (!(cd->flags & STREAM_DONE) && toRead > 0) {
- int n, decBytes;
+ unsigned int n; int decBytes;
/* if starting from scratch or continuation after full decompression */
if (!cd->inStream.avail_in) {
@@ -3127,7 +3176,7 @@ copyDecompressed:
static int
ZlibTransformOutput(
- ClientData instanceData,
+ void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -3160,7 +3209,7 @@ ZlibTransformOutput(
break;
}
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
@@ -3216,7 +3265,7 @@ ZlibTransformFlush(
* Write the bytes we've received to the next layer.
*/
- if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
+ if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
Tcl_PosixError(interp)));
@@ -3248,7 +3297,7 @@ ZlibTransformFlush(
static int
ZlibTransformSetOption( /* not used */
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
@@ -3269,7 +3318,10 @@ ZlibTransformSetOption( /* not used */
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
- (void) Tcl_GetByteArrayFromObj(compDictObj, NULL);
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
+ Tcl_DecrRefCount(compDictObj);
+ return TCL_ERROR;
+ }
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
@@ -3361,7 +3413,7 @@ ZlibTransformSetOption( /* not used */
static int
ZlibTransformGetOption(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
@@ -3417,7 +3469,7 @@ ZlibTransformGetOption(
} else {
if (cd->compDictObj) {
int len;
- const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len);
+ const char *str = TclGetStringFromObj(cd->compDictObj, &len);
Tcl_DStringAppend(dsPtr, str, len);
}
@@ -3482,7 +3534,7 @@ ZlibTransformGetOption(
static void
ZlibTransformWatch(
- ClientData instanceData,
+ void *instanceData,
int mask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3505,7 +3557,7 @@ ZlibTransformWatch(
static int
ZlibTransformEventHandler(
- ClientData instanceData,
+ void *instanceData,
int interestMask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3526,7 +3578,7 @@ ZlibTransformEventTimerKill(
static void
ZlibTransformTimerRun(
- ClientData clientData)
+ void *clientData)
{
ZlibChannelData *cd = (ZlibChannelData *)clientData;
@@ -3547,9 +3599,9 @@ ZlibTransformTimerRun(
static int
ZlibTransformGetHandle(
- ClientData instanceData,
+ void *instanceData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3568,7 +3620,7 @@ ZlibTransformGetHandle(
static int
ZlibTransformBlockMode(
- ClientData instanceData,
+ void *instanceData,
int mode)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3657,7 +3709,7 @@ ZlibStackChannelTransform(
if (compDictObj != NULL) {
cd->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(cd->compDictObj);
- Tcl_GetByteArrayFromObj(cd->compDictObj, NULL);
+ TclGetByteArrayFromObj(cd->compDictObj, NULL);
}
if (format == TCL_ZLIB_FORMAT_RAW) {
@@ -3893,13 +3945,22 @@ TclZlibInit(
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
- Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
+ Tcl_RegisterConfig(interp, "zlib", cfg, "utf-8");
+
+ /*
+ * Allow command type introspection to do something sensible with streams.
+ */
+
+ TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
/*
* Formally provide the package as a Tcl built-in.
*/
- return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
+#endif
+ return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION);
}
/*
@@ -4011,18 +4072,18 @@ Tcl_ZlibInflate(
unsigned int
Tcl_ZlibCRC32(
- unsigned int crc,
- const char *buf,
- int len)
+ TCL_UNUSED(unsigned int),
+ TCL_UNUSED(const unsigned char *),
+ TCL_UNUSED(int))
{
return 0;
}
unsigned int
Tcl_ZlibAdler32(
- unsigned int adler,
- const char *buf,
- int len)
+ TCL_UNUSED(unsigned int),
+ TCL_UNUSED(const unsigned char *),
+ TCL_UNUSED(int))
{
return 0;
}
diff --git a/generic/tommath.h b/generic/tommath.h
deleted file mode 100644
index 028a84d..0000000
--- a/generic/tommath.h
+++ /dev/null
@@ -1 +0,0 @@
-#include "tclTomMathInt.h"